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I .  INTRODUCTION 


The  development  of  large  caliber  gun  systems  utilizing  liquid  propellants 
in  place  of  conventional  solid  propellants  has  periodically  been  investigated 
in  the  United  States  since  the  late  1940' s.  A  number  of  liquid  propellant 
concepts  have  been  studied,  including  bulk  loaded  and  direct  injection  using 
both  bipropellants  and  monopropellants.  However,  research  since  the  mid  1970 's 
has  focused  on  the  regenerative  liquid  propellant  gun  (RLPG)  shown  in  Figure  1. 
The  characteristic  features  are  the  differential  piston  area,  the  injection 
orifice  and  the  propellant  reservoir. 


CONTROL 
ROD 


BEFORE  FIRING 


AFTER  FIRING 


Figure  1.  Regenerative  Liquid  Propellant . Gun.  Concept  VI. 

The  interior  ballistic  process  is  initiated  by  firing  an  igniter  which 
pressurizes  the  combustion  chamber.  The  chamber  pressure  acting  on  the  injection 
piston  forces  it  to  the  rear,  compressing  the  liquid  in  the  reservoir.  After 
an  initial  transient  period,  the  pressure  in  the  liquid  reservoir  will  exceed 
the  combustion  chamber  pressure  as  a  result  of  the  differential  area  across  the 
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inj ection  piston.  As  the  injection  piston  moves  to  the  rear,  opening  the  injection 
orifice,  liquid  propellant  is  injected  into  the  combustion  chamber,  where  it 
burns,  accelerating  the  projectile. 


The  interior  ballistic  process  in  the  regenerative  liquid  propellant  gun 
is  primarily  controlled  by  the  rate  of  injection  of  the  liquid  propellant,  and, 
thus,  by  the  motion  of  the  regenerative  piston.  In  the  interior  ballistic  models 
developed  to  dac  ,  the  equation  of  motion  for  the  regenerative  piston  has 
incorporated  only  the  pressure  and  friction  forces.  Equations  describing  the 
injection  of  the  liquid  propellant  from  the  liquid  reservoir  into  the  combustion 
chamber  have  generally  employed  a  steady-state  formulation  with  flow  losses. 
These  models,  in  general,  neglect  any  direct  coupling  between  the  piston  motion 
and  liquid  injection.  In  general,  the  acceleration  of  the  liquid  through  the 
injector  is  also  neglected,  resulting  in  equations  of  the  form,^ 


PAi 


1  - 


Ai 


t  3  "  c  5  \j  2{P  -  P  3)/Pi 


where  C^,  is  a  discharge  coefficient  adjusted  to  account  for  flew  losses. 

However,  the  above  treatment  has  several  inadequacies.  Review  of  experimental 
data  for  the  liquid  propellant  gun  has  suggested  that  the  discharge  coefficient 
has  unexpectedly  high  values  and  is  transient  in  nature  in  some  experiments . 2.3 
Thus,  the  formulation  described  above  requires  an  empirical  determination  of  the 
discharge  coefficient  for  various  nozzle  configurations.  Also,  in  the  case  of 
transient  values,  the  discharge  coefficient  must  be  determined  accurately  over 
the  critical  start-up  regime  of  the  interior  ballistic  process.  It  is,  therefore, 
of  interest  to  develop  a  model  which  does  not  require  a  discharge  coefficient. 
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but  which  will  accurately  predict  the  motion  of  the  regenerative  piston  and  the 
liquid  pressure  history.  Thus,  a  model  has  been  suggested  by  the  authors  which 
is  based  on  a  time -dependent  Bernoulli  equation  and  on  the  extension  of  the 
control  volume  to  include  the  entire  propellant  reservoir . 

The  present  work  is  a  continuation  of  the  treatmen*"  '•f  the  liquid  injection 
process  presented  by  Morrison  and  Wren  which  accounts  for  (1)  the  coupling  between 
the  regenerative  piston  motion  and  the  injection  of  liquid  propellant,  and  (2) 
the  inertia  of  the  liquid  in  the  reservoir.  In  this  paper,  results  of  the 
simulation  are  presented  and  compared  to  experimental  data.  Two  variations  of 
the  model  are  considered;  one  in  which  a  simplified  treatment  of  the  pressure 
distribution  in  the  liquid  reservoir  is  utilized  and  one  in  which  a  complete 
treatment  of  the  pressure  distribution  in  the  liquid  reservoir  is  considered  as 
part  of  the  injection  model.  The  distributions  are  derived  from  a  modified 
Lagrange  distribution  with  area  change  to  account  for  the  shape  of  the  regenerative 
piston  and  the  center  bolt.  In  this  paper  the  simple  and  full  models  are  compared 
to  each  other  and  to  experimental  data. 

Two  sets  of  experimental  data  are  examined,  both  from  30-mm  test  fixtures 
differing  primarily  in  the  use  of  resistive  forces  on  the  piston  and  transducer 
block  and  the  geometry  of  the  injection  orifice.  The  utility  of  the  simple 
version  and  the  full  version  of  the  injection  model  in  predicting  the  experimentally 
measured  motion  of  the  regenerative  piston,  the  liquid  pressure  and  the  derived 
values  of  the  discharge  coefficient  is  assessed.  In  general,  the  simple  model 
compares  well  with  experimental  data  for  Concept  VIA  fixtures,  and  the  full  model 
provides  little  additional  modeling  capability. 
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of  the  piston  and  the  reservoir  are  approximated  by  straight  line  segments  as 
indicated.  The  center  bolt,  which  is  fixed  in  these  designs,  is  cast  in  the 
reference  frame  of  the  chamber.  The  origin  of  the  coordinate  system  is  fixed 
at  the  rear  (left  hand)  end  of  the  reservoir,  and  x  is  the  coordinate  along  the 
bolt  as  shown  in  Figure  3.  The  piston  moves  rearward  with  a  velocity  Up,  and 
the  points  s^,  S2,  and  S3  are  the  coordinates  of  fixed  stations  on  the  inner 
contour  of  the  piston  with  respect  to  the  origin,  as  shown,  such  that  these 
coordinates  vary  with  time  as  the  piston  is  displaced  to  the  left.  The  right 
hand  face  of  the  control  volume  is  attached  to  the  chamber  face  of  the  piston, 
S3,  such  that  the  control  volume  also  varies  with  time. 


“IT 


1  2  3 


Figure  3 .  Control  Volume  for  Concept  VI 


The  derivation  of  both  the  simple  and  the  full  models  has  been  presented  in 
earlier  reports  and  will  not  be  repeated  here.  However,  in  general,  the  analysis 
begins  with  the  one -dimensional  momentum  and  continuity  equations  for  the  motion 
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of  the  liquid  in  the  reservoir  and  is  written  to  include  area  change  as  the 
piston  moves  rearward.  The  area  through  which  the  fluid  flows  is  a  function  of 
both  time  and  position,  since  the  contoured  piston  moves  rearward  over  a  contoured 
bolt.  The  equations  of  motion  for  the  fluid  (continuity  and  momentum)  are  then 

dt  dx  ^ 


and, 


<}(p«;/J)  ,  a(p^M)  ^dP 

~dr~  "  ‘  ■ 

where  p.v.A  and  P  are  all  functions  of  both  position  and  time. 

The  Lagrange  assvimption,  density  is  a  function  of  time  only  and  is  thus 
constant  over  the  control  volume  such  that  the  spatial  derivative  is  zero,  is 
a  good  approximation  in  the  case  of  the  LP  reservoir  since  the  liquid  density 
only  varies  by  about  4%  over  the  entire  ballistic  cycle  and  the  spatial  variation 
over  the  reservoir  at  any  given  time  is  much  less  than  this.  Therefore,  the 
Lagrange  approximation,  ^  -  0,  is  applied. 

The  analysis  produces  an  unsteady  Bernoulli  equation  and  a  relation  between 
the  exit  pressure  in  the  liquid  at  S3  and  the  space -mean  pressure  in  the  liquid 
provided  by  the  equation  of  state  for  liquid  propellant.  This  formulation  allows 
a  coupling  of  the  injection  velocity  of  the  liquid  to  the  velocity  of  the  piston 
by  considering  the  momentum  equation  of  the  control  volume  including  the 
regenerative  piston.  The  momentum  equation  of  the  control  volume  shown  in  Figure 
3,  in  the  reference  frame  of  the  chamber,  is 

MpU  *  T  f  f  dA  =  -  f  Pd  A  ,  (3) 

ol  J  cv  J  cs  J 
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where  is  the  outward  directed  normal  from  the  element  of  control  surface. 
Rewriting  Equation  (3), 


Mpiip  ~  Tt  \j  pvAdxj  -  *  ^3)  ~  Po^r  *  .  (4) 

The  unsteady  Bernoulli  ennation  and  the  force  balance  equation  for  the 
piston  are  the  coupled,  ordinary  differential  equations  of  motion  governing 
liquid  injection  and  injector  piston  motion.  Experimental  chamber  pressure  from 
an  experimental  gun  firing  provides  a  boundary  condition  for  the  problem. 

In  the  full  model  the  space-mean  pressure  is  taken  accurately  to  be 

^(0  “  — f  'P(x.0/l(x./)dx  (5) 

which  treats  the  contours  of  the  regenerative  piston,  while  in  the  simple  model 
the  space  mean  pressure  is  considered  only  on  the  straight  portion  of  the  piston. 
This  implies  a  much  higher  degree  of  complexity  in  the  equations  describing  the 
liquid  and  piston  accelerations  in  the  full  model  compared  to  the  simple  model. 
The  resulting  system  of  ordinary  differential  equations  in  the  full  model  is 
then: 


*  U\t)  (6) 

-  /’3(0[/4p^/43]  -  P(.l)A,^pv\A^-p[U^A{t)]  (7) 
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together  with  the  equation  of  state  for  liquid  propellant 


where  -  —  and  where  the  terms  required  by  the  equations  for  the  liquid  and 
piston  acceleration  are  defined  in  Appendix  A. 

Both  the  simple  and  full  versions  of  the  injection  model  are  heavily  geometry 
dependent,  with  the  major  differentiation  between  them  being  the  detail  captured 
in  the  development  of  the  pressure  gradient  in  the  liquid  reservoir.  In  the 
simple  model  the  Lagrange  pressure  distribution  with  area  change  considers  only 
the  straight  portion  of  the  piston.  That  is,  considering  the  interval  [0,Si] 
as  shown  in  Figure  3 , 

?(0  -  Pix.rjdx  (9) 

the  space -mean  pressure  is  not  treated  over  the  entire  reservoir  and  does  not 
include  the  contour  of  the  piston.  This  simplification,  while  not  an  accurate 
description  of  the  pressure  distribution  in  the  liquid  reservoir,  was  felt  to 
be  adequate  for  the  resulting  description  of  liquid  injection  and  is  a  significant 
simplification  of  the  model  equations.  The  comparison  with  experimental  data 
presented  later  in  this  report,  in  fact,  shows  that  it  is  a  good  approximation. 
The  resulting  system  of  ordinary  differential  equations  in  the  simple  model 
replaces  Equations  (6)  and  (7)  with 


a 


^CvI*2v3U^')  -  Pih,*h',) 


(10) 


UpM„  +  «^3P\ ^2 


)/•« 


P^iOAp  -  PCOAj^pvlA, 


(11) 


where 


h' 


/ 


Up) 


2 


( 


(12) 


is  a  representation  of  liquid  loss  through  the  orifice  which  has  been  adapted 
from  pipe  flow  and  hf  is  friction  acting  on  the  piston.  In  the  comparisons  which 
follow  both  terms  have  been  ignored.  An  assessment  of  possible  friction  acting 
on  the  piston  was  made,  and  in  the  fixtures  examined  these  forces  are  very  small 
compared  to  the  forces  associated  with  the  liquid  and  chamber  pressures. 


III.  GEOMETRIC  INTEGRALS  FOR  CONCEPT  VIA  GEOMETRY 


The  geometric  dependence  of  the  area  and  volume  terms,  even  in  the  simple 
model ,  requires  that  the  geometric  integrals  be  rederived  for  different  relative 
placement  of  the  points  describing  the  piston  and  center  bolt.  That  is,  use  is 
made  in  the  model  of  area  and  volume  relationships  defined  by  the  contours  of 
the  outer  piston  and  center  bolt.  Since  a  derivation  of  the  geometric  integrals 
for  the  Concept  VI  pictured  in  Figure  1  was  presented  in  an  earlier  paper,*  the 
integrals  derived  here  are  those  required  in  the  simple  model  for  the  Concept 
VIA  configuration  depicted  in  Figure  2.  It  is  possible  to  nximerically  evaluate 
the  integrals.  However,  a  numeric  solution  slows  the  computer  simulation  and 
was  replaced,  when  possible,  by  an  analytic  solution. 
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Referring  to  Figure  4,  the  following  terms  are  redefined  for  a  Concept  VIA 
fixture  when  utilizing  the  simple  model.  The  radius  of  the  piston  is  given  by 

V  S3~S2  ) 

with  Rj  the  radius  at  s^.  The  radius  of  the  bolt  is  given  by 

rt(x,0  =  r,  +  -^^^— ^(x-x,)[l  -//(x,-x)]  (14) 

X2  X, 
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with  the  radius  at  and  where  H(x}  is  the  Heaviside  function 


//(x)»0.x<0 
“  1  .  x>0. 


Then  proceeding  with  a  derivation  similar  to  that  described  for  the 
fixture/  the  geometric  Integrals  are  given  by 


AJo,(0 


C3  +  C4 


nMi 


Ml 


C5+C6> 


where  l^j  represents  the  length  from  s^  to  Sj  and 


1  (<|-r»)(gz*r») 

2r6  + 


(15) 

Concept  VI 

(16) 

(17) 

(18) 

(19) 

(20) 

(21) 
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(29) 


Finally,  it  was  decided  to  include  a  term  which  was  not  evaluated  in  the  Concept 
VI  simple  model,  the  time  rate  of  change  of  vent  area.  Since 


I  _  rt,(x2)-rt(.vi) 

dx  /13  Xj-  X, 


(30) 


where  M3  represents  the  slope  of  the  diverging  section  of  the  bolt  which  opens 
the  vent  area  during  the  startup,  and 

d3-n(S(s3)^-r^(x)),  x6[x,.xa]  (31) 

then 


^3(0“2nUpM3,  x€[x,.X2] 

-0  otherwise.  (32) 

The  terms  defined  above  were  employed  in  the  simple  version  of  the  injection 
model  for  Concept  VIA  and  are  compared  to  experimental  data  as  shown  in  the 
following  section. 
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IV.  MODEL  VALIDATION:  30-mm,  Concept  VIA 


To  assess  the  simple  model,  an  experimental  firing  of  a  30-mm,  Concept  VIA 
fixture  with  a  damper  and  without  Belleville  springs,  part  of  the  General  Electric 
variable  volume  series  and  labeled  Shot  7,  was  utilized.  The  filtered,  experimental 
data  from  this  shot  is  shown  in  Figure  5.  This  fixture  utilizes  a  damper  on  the 
outer  piston  primarily  intended  to  slow  the  piston  near  completion  of  stroke. 
Also,  absent  from  the  fixture  are  the  Belleville  springs  used  to  aid  the  startup 
of  injection  in  earlier  guns  such  as  the  30-mm  Concept  VI  fixture  at  BRL.  The 
experimental  data  shows  some  initial  unsteady  motion  in  the  piston  with  cor¬ 
responding  reflection  in  the  slight  liquid  pressure  oscillations,  but  overall 
smooth  piston  stroke.  The  unfiltered  chamber  pressure  shows  the  presence  of 
high  frequency  oscillations  associated  with  much  of  the  liquid  propellant  data. 
The  shot  is  felt  to  be  typical  of  30-mm,  Concept  VIA  data.® 

As  noted  previously,  the  injection  model  currently  uses  experimental  combustion 
chamber  pressures  as  a  boundary  condition.  However,  the  model  does  not  require 
the  input  of  a  discharge  coefficient  for  the  liquid  injection  from  the  reservoir 
to  the  combustion  chamber,  predicting  this  value  instead.  The  input  consists 
of  lengths,  areas  and  volumes  associated  with  the  gun.  Although  it  is  possible 
to  model  the  damper,  the  damper  pressure  was  included  as  an  additional  boundary 
condition  since  the  interest  here  is  assessment  of  the  injection  model.  The 
momentum  equation  for  the  control  volume  is  then  modified  to 


-  (33) 
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where  Pg  is  the  pressure  of  the  damper  and  Ap  is  the  projected  area  against  the 


damper . 


SYSTEM  PRESSURES  PHD  PISTOl'l  POSIT  I  CM 


Figure  3.  Experimental  Chamber  Pressure.  Liquid  Pressure.  Damper  Pressure 
and  Piston  Position  from  a  30-mm.  Concept  VIA  RLPG  (GE  Shot  71 


It  is  noted  that  the  unfiltered  experimental  chamber  pressure  has  high 
frequency  oscillations.  Thus,  it  is  necessary  to  filter  the  experimental  data 
before  an  acceptable  boundary  condition  can  be  given.  Since  the  frequencies  in 
the  combustion  chamber  have  not  yet  been  ascribed  a  specific  physical  significance  , 
a  reasonable  filtered  fit  to  the  experimental  data  was  sought,  in  this  case  a 
5KHz  low  pass  filter  with  a  lOOHz  transition.  An  overlay  of  the  filtered  and 
unfiltered  data  shows  that  the  structure  of  the  pressure -time  curve  has  been 


maintained,  but  the  oscillativ'>ns  have  beer,  removed.  It  is  noted,  however  ,  that 
the  specific  filter  utilized  can  affect  the  predicted  values  of  the  discharge 
coefficient . 

The  nonlinear  ordinary  differential  equations  describing  liquid  injection 
in  the  simple  model  together  with  the  boundary  conditions  of  chamber  pressure 
and  damper  pressure  are  then  numerically  solved  on  an  IBM-AT  personal  computer 
using  SDRIV,®  an  efficient  and  robust  computer  code  for  the  solution  of  initial 
value  problems  for  ordinary  differential  equations  which  solves  both  stiff  and 
non- stiff  problems.  The  system  of  nonlinear  ordinary  differential  equations 
posed  in  this  paper  was  solved  as  a  stiff  problem.  A  listing  of  the  input  file 
can  be  found  in  Appendix  B. 

A  comparison  of  the  simulation  to  measured  experimental  piston  position  and 
liquid  pressure  is  shown  in  Figures  6  and  7,  respectively.  The  comparison  of 
piston  position  shows  good  overall  agreement  both  qualitatively  and  quantita¬ 
tively,  although  several  of  the  details  in  the  experimental  data  are  not  captured. 
The  model  does  not  reflect  the  somewhat  bumpy  startup  of  the  experimental  piston, 
and  it  does  not  slow  to  match  experimental  data  at  the  end  of  stroke.  A  comparison 
of  liquid  pressure  shows  similar  good  agreement  although  the  model  does  not 
reflect  the  small  oscillations  in  the  experimental  pressure.  The  computed 
discharge  coefficient  is  shown  in  Figure  8.  It  exhibits  a  quick  rise  to  steady 
state  with  a  mean  value  of  approximately  0.95,  a  value  generally  accepted  for 
these  fixtures.  The  value  of  the  discharge  coefficient  derived  from  the 
experimental  data  is  shown  in  Figure  9.  The  experimental  values  of  the  discharge 
coefficient  in  Figure  9  are  not  measured  directly  and  are  subject  to  a  high 
degree  of  inaccuracy  since  a  slight  inaccuracy  in  calculating  the  vent  area  can 
significantly  affect  the  derived  values  of  the  discharge  coefficient.  After  a 
rather  long  transient  period,  the  quasi-steady  state  value  of  the  experimental 
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discharge  coefficient  appears  to  be  approximately  0.95.  Therefore,  considering 
the  mean  values,  the  experimental  and  simulated  discharge  coefficients  are  felt 
to  be  in  reasonable  agreement. 


In  general,  the  simple  model  appears  to  be  an  accurate  representation  of 
experimental  piston  position  and  liquid  pressure  with  chamber  and  damper  pressures 
included  as  boundary  conditions  for  a  Concept  VIA,  30-mm  RLPG.  The  model  requires 
the  geometry  of  the  fixture  as  input,  with  the  discharge  coefficient  predicted 
by  the  model.  It  appears  that  the  more  complex,  full  model  is  not  required  to 
describe  the  injection  process  in  the  Concept  VIA  fixture. 


Figure  6.  Comparison  of  Simple  Injection  Model  with  Experimental  Piston 
Poaitionfrom  a  3Q-mm.  Concept  VIA  RLPG  (GE  Shot  71. 
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TIMEIMSI 


Figure  7 .  Comparison  of  Simple  Injection  Mode 
Pressure  from  a  30-nim.  Concept  ^ 
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TIME  IMS) 

Figure  8.  Predicted  Values  of  the  Discharge  C( 
Injection  Model  for  a  30-iiim.  Cone 
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IDEAL  AND  ACTUAL  VOLUME  FLOW 


Figure  9 .  Derived  Values  of  the  Discharge  Coefficient  from  Experimental 
Pressures  and  Derived  Ideal  and  Actual  Volume  Flow 
for  a  3Q-iim.  Concept  VIA  RLPG  (GE  Shot  7). 


V.  MODEL  APPLICATION:  30-imn,  Concept  VI 

The  original  impetus  for  the  injection  model  was  reports  of  unexpectedly 
high  values  of  the  discharge  coefficient. 2. 3  The  30-mm,  Concept  VI  RLPG  at  the 
Ballistic  Research  Laboratory  became  the  focus  of  investigation,  and  it  is  a 
firing  labeled  Round  8  that  has  received  the  most  scrutiny.  In  an  effort  to 
explore  this  data  set,  a  number  of  approaches  were  taken.  In  this  section  an 
assessment  is  made  of  the  simple  model's  ability  to  capture  the  experimental 
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piston  position  and  liquid  pressure  in  Round  8.  This  required  expanding  the 
model  by  adding  two  additional  simultaneous  equations  describing  the  motion  of 
the  transducer  block  against  the  Belleville  springs.  The  required  equations  are 


y 


Mr 


ky] 


(34) 


and 


y  -  y 


(35) 


where  y  is  the  position  of  the  spring  from  its  initial  position  at  0.0  and  the 
spring  constant,  k,  is  determined  experimentally  from  a  measurement  of  the  springs 
alone . 

The  experimental  piston  displacement,  liquid  pressure  and  filtered  chamber 
pressure  for  a  30-mm,  Concept  VI  RLPG  (BRL  Round  8)  is  shown  in  Figure  10.  The 
piston  begins  to  move  at  about  1.25  ms,  travels  approximately  0.5  cm,  abruptly 
stops  at  about  3.5  ms,  hesitates  briefly  and  then  again  accelerates  and  smoothly 
completes  its  stroke.  This  interrupted  piston  motion  is  caused  by  the  rear 
transducer  block  moving  rearward  against  a  set  of  Belleville  springs  in  order 
to  permit  the  piston  to  clear  an  0-ring  seal  on  the  forward  end  of  the  center 
bolt.  Injection  is  designed  to  begin  with  compression  of  the  Belleville  springs 
and  unseating  of  the  0-ring.  When  the  springs  are  fully  compressed,  the  transducer 
block  abruptly  stops,  as  does  the  reservoir  and  the  piston.  The  piston  then 
accelerates  rearward  again  as  liquid  injection  begins  and  completes  its  stroke. 
The  propellant  in  the  reservoir  is  much  stiffer  than  the  combustion  gases,  and 
thus  reflects  the  abrupt  variations  in  the  piston  motion.  As  the  Belleville 
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springs  begin  to  compress,  a  small  oscillation  In  liquid  pressure  Is  observed 
at  about  3.0  ms.  When  the  transducer  block  suddenly  stops  at  about  3.5  ms,  the 
momentum  of  the  piston  Is  absorbed  by  the  liquid,  producing  the  relatively 
large  pressure  oscillations  from  3.5  to  5.0  ms.  Although  Initially  undamped, 
as  the  Injection  area  opens  the  oscillations  are  rapidly  damped.  Similarly,  as 
the  piston  reaches  the  rear  taper,  which  reduces  the  liquid  Injection  area,  the 
liquid  pressure  rises  sharply  as  the  piston  Is  decelerated.  The  liquid  gauge 
falls  just  as  damping  begins  at  about  8  ms. 


3 
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Figure  10.  Experimental  Chamber  Pressure.  Liquid  Pressure  and  Piston 
Position  for  a  30-mm.  Concept  VI  RLPG  (BRL  Round  8). 


The  simple  model  employing  the  Concept  VI  geometry  with  the  inclusion  of 
a  Belleville  spring  model  together  with  experimental  combustion  chamber  pressure 
as  a  boundary  condition  was  utilized  as  a  model.  The  input  file  can  be  found 
in  Appendix  C.  The  comparison  of  the  simulation  with  experimental  liquid  pressure 


and  piston  position  is  shovm  in  Figures  11  and  12,  respectively,  where  the  zero 
in  time  has  been  chosen  to  coincide  with  the  Initial  rise  in  combustion  chamber 
pressure.  The  oscillation  in  liquid  pressure  at  2.4  ms  and  the  corresponding 
flattening  of  the  piston  position  is  associated  with  the  bottoming  out  of  the 
Belleville  springs.  The  major  observation  is  that,  although  the  model  is  in 
general  agreement  with  experiment,  the  timing  of  events  appears  to  be  inaccurate. 
Although  the  piston  velocity,  as  evidenced  by  the  slope  of  the  piston  position 
versus  time  curve  in  figure  8,  appears  to  agree  with  the  experiment,  the  Belleville 
springs  bottom  out  too  quickly  in  the  model  as  evidenced  by  the  both  the  early 
flattening  of  the  piston  position  curve  and  the  early  oscillations  in  the  liquid 
prassure.  Two  possibilities  were  considered  for  this  inconsistency.  First,  it 
was  hypothesized  that  there  may  be  friction  associated  with  the  seals  and  the 
grease  column  which  is  not  captured  by  the  model.  Secondly,  it  is  noted  that 
several  model  assumptions  are  not  accurate  representations  of  the  physical 
problem. 


Figure  11.  Comparison  of  Simple  Model  Simulation  and  Experimental 
Liquid  Pressure  for  a  3Q-mm.  Concept  VI  RLPG  (BRL  Round  S’). 
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Figure  12.  Comparison  of  Simple  Model  Simulation  and  Experimental  Platon 
Position  for  a  lO-mm  Concent  VI  RLPG  (BRL  Round  8^. 


To  explore  the  possibility  of  friction  from  the  seals  and  grease  affecting 
piston  motion  during  the  start-up  regime  when  the  piston,  liquid  propellant  and 
transducer  block  are  moving  rearward  against  the  Belleville  springs,  a  separate 
point  mass-spring  model  was  written.  The  point  mass-spring  model  was  utilized 
to  compute  the  expected  timing  of  the  event  of  the  bottoming  of  the  Belleville 
springs.  Until  the  bottoming  of  the  springs,  the  liquid  reseirvoir  is  sealed  by 
an  0-ring.  Thus,  during  the  initial  motion,  the  transducer  block  mass,  liquid 
propellant  mass  and  piston  mass  are  considered  a  point  mass  moving  against  the 
Belleville  springs.  The  spring  coefficients  were  provided  by  direct  measurement 
of  the  springs  alone .  The  model  equation  is 
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with 


(36) 


X 


M 


-CO  X 


where  fcCO  is  the  combustion  chamber  pressure,  Ac  is  the  projected  area  of  the 

liquid  in  the  reservoir  against  the  springs,  k  is  the  spring  constant,  and  M 
is  the  point  mass  consisting  of  piston  mass,  liquid  propellant  mass  and  transducer 
mass.  The  liquid  propellant  in  the  liquid  reservoir  is  initially  prepressurized 
to  6.6  MPa  which  forces  the  piston  forward  against  a  crash  ring  and  moves  the 
transducer  block  rearward  against  the  Belleville  springs  0.177  cm.  In  this 
position,  the  system  starts  from  rest  and  begins  motion  in  response  to  the  rise 
in  combustion  chamber  pressure. 


Experimental  measurement  of  the  Belleville  springs  shows  that  the  full 
displacement  of  the  springs  is  0.422  cm.  Since  the  liquid  reservoir  is  filled 
with  propellant,  and  the  chamber  pressures  are  low,  the  liquid  propellant 
compressibility  can  be  ignored  during  the  first  few  milliseconds.  Hence,  the 
expectation  is  that,  for  the  movement  of  the  transducer  block  against  the 
springs,  the  piston  will  move  somewhat  further.  Since  the  piston  and  the 
transducer  will  not  displace  the  same  amount  during  the  startup  (the  volume 
displaced  by  linear  motion  of  the  transducer  is  more  than  that  displaced  by  the 
same  movement  of  the  piston) ,  it  is  not  possible  to  compare  experimental  piston 
displacement  with  the  displacement  of  the  transducer  predicted  by  the  model. 
The  interest,  then,  is  the  timing  of  the  event.  As  can  be  seen  from  Figure  10, 
the  experimental  liquid  pressure  reflects  the  bottoming  of  the  springs  at  about 
3.65  ms  as  evidenced  by  the  sharp  rise  in  liquid  pressure.  The  point  mass  model 
predicts  that  the  springs  bottom  out  at  3.60  m.  Thus,  there  is  no  evidence  of 
significant  friction  affecting  piston  motion  during  the  start-up  regime. 
Therefore,  the  simple  model's  inability  to  capture  the  initial  piston  motion  is 
not  explained  by  friction  in  the  system. 
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Secondly,  several  representations  in  the  simple  model  do  not  accurately 
reflect  the  physical  problem.  The  major  concerns  are  addressed  in  the  following 
section.  However,  for  completeness,  the  following  inconsistencies  between  the 
model  and  the  physical  problem  in  Round  8  are  noted. 

(1)  The  fixed  zero  in  the  control  volume  is  displaced  0.177  cm  in  the 
physical  problem  by  the  pre-pressurization  of  the  liquid  reservoir.  Thus,  the 
lengths  used  in  the  model  from  the  zero  position  are  slightly  inaccurate. 

(2)  It  is  assumed  implicitly  in  the  model  that  the  transducer  block  and 
the  piston  move  rearward  as  a  unit  during  startup  maintaining  the  lengths  on 
[0,Si].  To  conserve  the  liquid  reservoir  volume,  the  piston  will  move  slightly 
further  than  the  springs  due  to  the  variation  in  area. 

(3)  The  momentum  equation  in  the  model  does  not  account  for  a  moving  rear 
boundary.  In  the  physical  problem  the  rear  transducer  block  moves  against  the 
springs . 

(4)  Although  the  initial  vent  area  in  the  experiment  is  zero  and  remains 
zero  until  the  0-ring  is  expelled,  the  model  will  not  allow  a  zero  vent  area 
since  it  occurs  as  a  divisor.  Thus,  although  the  initial  vent  area  in  the 
simulation  is  kept  as  small  as  possible  to  allow  the  code  to  run,  a  small  amount 
of  liquid  is  expelled  during  the  startup  region. 

(5)  The  pressure  gradient  in  the  liquid  reservoir  was  considered  over  the 
straight  portion  of  the  piston,  as  a  modeling  simplification,  instead  of  over 
the  entire  reservoir. 
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(6)  Although  the  contour  of  the  center  bolt  is  reflected  In  the  vent  area, 
the  geometry  of  the  center  bolt  was  not  included  in  the  evaluation  of  the  area 
integrals . 

Of  the  concerns  listed  above,  only  the  simplification  of  the  pressure 
gradient  was  expected  to  affect  the  solution.  Thus,  the  most  promising  extension 
of  the  simple  model  appeared  to  be  a  precise  statement  of  the  space-mean  pressure, 
that  is,  application  of  the  full  model.  The  extension  of  the  pressure  gradient 
to  the  entire  reservoir  significantly  complicates  the  model,  and  it  was  necessary 
to  both  rederive  the  governing  equations  and  to  move  the  equations  to  a  mainframe 
computer  for  solution.  In  the  next  section,  the  results  from  the  full  model 
with  inclusion  of  the  complete  pressure  gradient  is  examined. 

In  general,  although  the  simple  model  is  an  adequate  description  of  the  30-mm, 
Concept  VIA  RLPG,  and  captures  the  basic  physics  of  the  30-mm  Concept  VI  RLPG, 
it  does  not  accurately  model  the  detail  associated  with  the  early  start-up  regime 
in  the  Concept  VI  fixture. 


VI.  COMPARISON  OF  SIMPLE  AND  FULL  INJECTION  MODELS 

To  further  explore  the  discrepancies  between  the  simulation  and  the 
experimental  data  from  Round  8  discussed  in  Section  VI,  the  simple  model  was 
expanded  to  consider  the  full  pressure  distribution  by  removing  the  restriction 
of  considering  the  space-mean  pressure  only  on  the  straight  portion  of  the  piston 
in  the  derivation  of  the  Lagrange  pressure  distribution  with  area  change.  As 
shown  earlier  in  Appendix  A,  the  resulting  integrals  are  complex,  and,  although 
possible  to  analytically  simplify,  do  require  numeric  integration  to  determine 
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their  final  values.  A  listing  of  the  code  can  be  found  in  Appendix  D.  In  this 
section  the  full  and  simple  models  are  compared  to  each  other  and  to  the 
experimental  data  of  Round  8. 

As  an  intermediate  step  in  the  comparison,  and  to  validate  the  analysis, 
the  full  Lagrange  pressure  and  velocity  distributions  with  area  change  in  the 
liquid  reservoir  were  compared  to  a  one -dimensional  simulation  of  the  reservoir^° 
since  no  experimental  data  exists  for  the  liquid  other  than  a  single  pressure 
measurement  at  each  timestep.  The  full  Lagrange  pressure  and  velocity  dis¬ 
tributions  have  been  derived  elsewhere, ^  and  are  a  result  of  considering  the 
space-mean  pressure  through  the  entire  liquid  reservoir. 

To  assess  the  accuracy  of  the  resulting  model  of  pressure  and  velocity 
distribution  in  the  liquid  reservoir,  the  Lagrange  model  is  compared  with  a 
one -dimensional  simulation  in  Figures  13  and  14  at  a  mid-stroke  position  of  the 
piston.  As  is  evident  from  the  figures,  the  models  are  in  excellent  qualitative 
and  quantitative  agreement  with  a  difference  of  less  than  1%  in  liquid  propellant 
velocity  and  pressure  at  the  exit  of  the  liquid  propellant  from  the  liquid 
reservoir  into  the  combustion  chamber.  Thus,  the  inclusion  of  the  full  pressure 
gradient  into  the  injection  model  was  felt  to  more  accurately  reflect  the  actual 
conditions  in  the  reseirvoir. 

Accordingly,  the  full  model  incorporates  a  consideration  of  the  complete 
geometry  of  the  piston.  The  contour  of  the  center  bolt  was  not  included  in  the 
geometric  integrals,  but  could  be  at  the  expense  of  more  complication.  In  the 
figures  which  follow  the  simple  and  full  injection  models  are  compared  to 
experimental  data  from  the  30-mm,  Concept  VI  RLPG  firing  labelled  Round  8  just 
after  the  Belleville  springs  have  bottomed  out.  Thus,  the  zero  in  time  has  been 
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chosen  to  correspond  to  the  bottoming  of  the  springs  at  approximately  3.65  ms 
in  the  original  experimental  data.  The  initial  conditions  of  piston  position 
and  velocity  were  determined  from  experimental  data. 
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In  Figure  15  a  comparison  of  piston  position  shows  that,  although  the  full 
model  is  more  accurate  than  the  simple  model  in  comparison  to  experimental  piston 
position,  neither  reflect  the  delay  from  approximately  0.0  to  2 . 0  ms  in  establishing 
the  experimental  piston  velocity. 

The  comparison  of  the  simple  and  full  simulations  of  liquid  pressure  with 
experimental  liquid  pressure  is  shown  in  Figure  16.  Although  the  first  oscillation 
in  liquid  pressure  is  reflected  in  both  models,  the  oscillations  in  the  two 
injection  modals  simply  become  damped  too  quickly,  showing  the  most  significant 
departure  from  1.0  to  2.5  ms  where  the  experimental  liquid  pressure  is  noticeable 
higher  than  the  simulations.  It  is  in  this  regime  that  the  piston  position  is 
also  not  accurate.  The  higher  liquid  pressure  and  slowed  piston  may  indicate 
that  the  flow  of  liquid  propellant  has  been  disturbed  in  the  experiment.  In 
operation  the  flow  of  liquid  propellant  unseats  the  0-ring  into  the  combustion 
chamber  opening  the  vent.  If  the  0-ring  did  not  unseat  uniformly,  it  could  block 
the  initial  flow  of  liquid  leading  to  higher  liquid  pressure  than  predicted  and 
a  correspondingly  slower  piston.  The  difference  in  magnitude  of  the  pressure 
oscillations  also  indicate  that  the  model  may  not  have  an  accurate  value  for  the 
bulk  modulus.  Once  the  oscillations  have  damped,  however,  both  models  agree 
with  experimental  values  through  the  steady  state  regime  with  some  deviation 
near  end  of  stroke.  The  full  model  more  accurately  captures  the  end  of  stroke 
and  follows  the  experimental  liquid  pressure  through  the  decrease  just  before 
the  gauge  fails. 

The  calculated  values  of  the  discharge  coefficient  are  shown  in  Figure  17 
for  the  simple  and  full  models  in  comparison  with  the  values  of  the  discharge 
coefficient  derived,  not  directly  measured,  from  experimental  data.  As  expected, 
the  values  of  the  simulated  discharge  coefficients  follow  the  general  observations 
for  the  piston.  Both  exhibit  initial  wide  fluctuations  and  establishment  of  a 
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steady  state  value  by  1.0  ms.  From  1.0  ms  to  2.0  ms  the  values  for  the  full 
model  are  lower  than  for  the  simple  model  reflecting  the  slower  piston  observed 
in  Figure  15.  The  mean  values  of  both  models  are  approximately  0.9  which  agree 
well  with  the  calculated  mean  values  of  the  discharge  coefficient  from  experiment 
as  shown  in  Figure  17.  However,  the  inability  of  the  model  to  predict  a  time 
varying  discharge  coefficient  which  is  predominantly  a  monotonically  increasing 
function  over  the  first  few  milliseconds  of  the  ballistic  event  reflects  indirectly 
the  inability  of  either  model  to  capture  the  slow  piston  over  the  same  time 
period.  It  may  well  be  that  Round  8  represents  an  anomaly  in  operation  of  the 
liquid  propellant  gun.  The  characteristic  of  a  ballistically  long,  slow  rise 
to  steady  state  is  not  seen  in  data  from  RLPGs  with  the  Belleville  springs 
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removed.  The  use  of  Belleville  springs  was  a  convenient  method  of  breaking  the 
initial  seal  between  the  inner  piston  and  bolt  in  early  test  fixtures.  However, 
most  fixtures  built  after  1985  have  incorporated  metal  to  metal  seals  and  utilized 
dampers  with  water  or  oil  to  modulate  the  piston  motion. 


Figure  17.  Comparison  of  the  Simple  and  Full  Models  with  Derived 
Values  of  the  Discharge  Coefficient  from  a  30 -mm. 
Concept  VI  RLPG  (BRL  Round  81. 


In  general,  the  full  model  represents  an  improvement  over  the  simple  model 
in  its  ability  to  more  accurately  predict  the  startup  regime  and  end  of  stroke 
in  a  30-mm,  Concept  VI  RLPG.  However,  both  the  simple  and  full  models  are  in 
reasonable  qualitative  and  quantitative  agreement  with  experiment,  and,  in  fact, 
the  simple  model  captures  the  injection  process  in  the  30-mm  RLPG  without 
Belleville  springs  as  exhibited  by  Shot  7. 
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VII .  CONCLUSIONS 


A  model  of  liquid  injection  in  a  regenerative  liquid  propellant  gun  has 
been  developed  which  couples  the  motion  of  the  regenerative  piston  to  the  flow 
of  liquid  propellant  from  the  reservoir  into  the  combustion  chamber.  The  model 
is  based  on  a  generalization  of  the  Lagrange  approximation  to  address  the  variation 
of  fluid  mass  in  the  reservoir  during  the  ballistic  cycle;  the  variation  of  area 
with  position  in  the  reservoir;  and  the  variation  of  area  with  time  at  a  fixed 
position  in  reservoir  due  to  the  rearward  motion  of  the  contoured  injection 
piston.  It  is  applicable  to  Concept  VI  and  Concept  VIA  geometries  with  a 
stationary  center  bolt.  Two  versions  of  the  model  have  been  considered;  a  simple 
model  which  utilizes  a  simplified  statement  of  the  pressure  gradient  in  the 
liquid  reservoir  ;  and  a  full  model  which  extends  the  pressure  gradient  to  consider 
the  contours  of  the  piston  head  and  injection  orifice.  The  following  conclusions 
about  the  model  have  been  presented  in  this  paper. 

1)  Compared  to  experimental  data,  the  simple  model  adequately  describes 
the  motion  of  the  regenerative  piston  and  liquid  pressure  history  for  the  Concept 
VIA  fixture  with  a  damper  and  without  Belleville  springs.  The  predicted  values 
of  the  discharge  coefficient  are  in  reasonable  agreement  with  experimentally 
derived  mean  values. 

2)  The  simple  model  does  not  accurately  capture  the  start-up  regime  of  the 
Concept  VI  fixture  with  Belleville  springs.  In  addition,  the  simple  model  does 
not  predict  the  slow  rise  of  the  discharge  coefficient  to  steady  state  observed 
in  experiment. 

3)  The  full  model,  while  displaying  better  agreement  than  the  simple  model 
to  the  Concept  VI  experimental  piston  position  and  liquid  pressure,  does  not 
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predict  the  slow  rise  to  steady  state  observ"'*  in  the  experiment.  The  reasons 
for  the  lack  of  agreement  remain  speculative.  The  predicted  values  of  the 
discharge  coefficient  are  in  close  agreement  with  those  obtained  from  the  simple 
model . 

4)  The  predicted  mean  value  of  the  discharge  coefficient  is  0.95,  a  value 
which  agrees  with  experiment. 

In  general,  the  model  appears  to  be  an  improved  description  of  the  liquid 
injection  process  for  the  regenerative  liquid  propellant  gun  in  comparison  with 
current  lumped  parameter  models,  since  it  does  not  require  empirically  determined 
parameters . 
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h 
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APPENDIX  A 


DEFINITION  OF  TERMS 
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The  ordinary  differential  equations  given  by  Equations  (6)  and  (7)  in  the 
full  model  involve  a  number  of  geometric  integrals.  These  integrals  have  been 
analytically  simplified,  when  possible,  for  the  specific  geometry  of  the  Concept 
VI.  However,  it  is  necessary  to  evaluate  some  expressions  numerically  at  each 
timestep  since  area  is  a  function  of  both  piston  position  and  time.  The  complete 
derivation  has  been  presented  in  earlier  reports,  and  a  summary  is  provided  here 
of  those  expressions  necessary  to  solve  the  system  of  ordinary  differential 
equations . 
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The  terms  involving  J  and  the  mean  quanities  denoted  by  the  bar  are 
below. 
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Note  that  the  integrals  through  Jg  together  with  their  mean  values  are 
dimensionless,  while  the  integrals  and  and  their  mean  values  have  units  of 
length . 
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APPENDIX  B 


MODEL  INPUT  FOR  30 -MM,  CONCEPT  VIA 
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The  input  file  listed  below  is  descriptive  of  the  30-nmi,  Concept  VIA 
geometry  used  in  GE  Shot  7.  The  test  fixture  was  built  and  fired  by  the 
General  Electric  Company,  Tactical  Systems  Department,  under  contract 
DAAK11-84-C-0055. 


RLPLCH--30MM- -CONCEPT  6A 
45.5125  35.4957  23.7640 
1.397  1.6794 

0.0 

2012.0 

83.25821 

2 

2.159 

1.437  5661.1  9.2649 

0 
0 

D: CHAMB6A.DAT 
D:GE0MC6A.GE 
D : GE6A . GRA 
1.46  0.  0.  0.0 

0.0001  .00001 
10  0 

1.78562  2.0665782  3.27914 
1.78562  1.55575  1.55575 
21.2068 
5.5231896 
0 
0 

0.5588  0.76 

20  1 

D:DISTVP2.GRA 


SLICE- -MODEL  OF  GE  DATA 
AC  AP  AR  (CM**2) 

RLPRIME  RLVENT  (CM) 

OFFSET  (CM)  OF  PISTON  FROM  END  OF  BLT 
PMASS  (G) 

VOLFO  (CM**3) 

TVENT- -ACTUAL  PISTON 

RLTEMP- - (CM) - -ORIGINAL 

RHOL  RKl  RK2 

I FRL- -FRICTION  LOSS  OPTION  OF  LIQ 

IFRP- -FRICTION  LOSS  OPTION  OF  PIS 


PRES  VELH  UPISTON  XPISTON 

TINC  EPS 

METH  MITER  KWRITE 

DIFEQN--DIFF  EQN  SET 

RP3  RP2  RPl  (CM) --PISTON 

RB3  RB2  RBI  (CM) --PISTON 

VOL12  (CM**3) 

VOL23  (CM**3) 

IWRITE 

PRESSURE  DISTRIBUTION  OPTION 
RLBLTF  (BOLT  FLAT),RLBLTS  (BOLT  SLT) 
NPRPTS.IP  (NO.  PTS.OPEN  GRAPH  FILE) 
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Intentionally  left  blank. 
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The  input  file  listed  below  is  descriptive  of  the  30 -mm,  Concept  VI 
geometry  used  in  BRL  Round  8.  The  test  fixture  was  built  by  the  General 
Electric  Company,  Tactical  Systems  Department,  under  contract  DAAK11-84-C-0055 
and  fired  at  the  Ballistic  Research  Laboratory. 


RLPLCH- -ROUND 

8  -  - 30MM 

44.847  34.326 

23.278 

AC  AP  AR  (CM**2) 

1.432  1.04 

RLPRIME  RLVENT  (CM) 

0.544 

OFFSET  (CM)  OF  PISTON  FROM  END  OF  BLT 

2109.2 

PMASS  (G) 

172.62764 

VOLFO  (CM**3) 

2 

TVENT- -ACTUAL  PISTON 

5.94680 

RLTEMP- - (CM) - -ORIGINAL 

1.437  5350.0 

9.11 

RHOL  RKl  RK2 

0 

IFRL- -FRICTION  LOSS  OPTION  OF  LIQ 

0 

I FRP- -FRICTION  LOSS  OPTION  OF  PIS 

ptoff64 . dat 

r8geo55 . dat 

jannaf88 . gra 

29.  0.  358.  0. 

00 

PRES  VELH  UPISTON  XPISTON 

0.0001  .00001 

TINC  EPS 

10  0 

METH  MITER  KWRITE 

1 

DIFEQN--DIFF  EQN  SET 

1.83  1.83  3.28 

RP3  RP2  RPl  (CM) --PISTON 

1.7977  1.7977 

1.65 

RB3  RB2  RBI  (CM) --PISTON 

17.908367 

V0L12  (CM**3) 

2.0266094 

VOL23  (CM**3) 

0.5588  0.76 

RLBLTF  (BOLT  FLAT),RLBLTS  (BOLT  SLT) 

0 

IWRITE 

0 

PRESSURE  DISTRIBUTION  OPTION 

0.5588  0.76 

RLBLTF  (BOLT  FLAT),RLBLTS  (BOLT  SLT) 

20  1 

NPRPTS,IP  (NO.  PTS.OPEN  GRAPH  FILE) 

distvpll . gra 
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APPEDIX  D 


LISTING  OF  THE  FULL  VERSION  OF  THE  CODE 
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PROGRAM  INJECT 

*****  RLP  LIQUID  CHAMBER  ***** 

PROGRAM  TO  EXAMINE  THE  DISCHARGE  COEFFICIENT  DESCRIBING 
LIQUID  PROPELLANT  FLOW  IN  A  REGENERATIVE  LIQUID  PROPELLANT 
GUN  BY  COUPLING  MOTION  OF  REGENERATIVE  PISTON  AND  LIQUID 

DIMENSION  Y(4) ,YDOT(4) ,WK(1000) 

COMMON  /NAMES/  TITLE, DATA, GRAF, GEOM.VPDI ST 
COMMON  /FI2/  AC,AP,AR,AL,IDIFEQN 
COMMON  /FI 3/  RLPRIME,RLVENT,RLMAX,RLTEMP,RLT 
COMMON  /FI4/  PMASS, OFFSET 

COMMON  /FI5/  TVENT,NROD,SROD(20),RROD(20).AROD(20),JFLAG 
COMMON  /FI6/  RHOL,RKl,RK2,VOLFO,PSI,AV 

COMMON  /FI7/  IFRP,NOPT,NFLOSS.FRICPOS(20) ,FLOSS(20) ,NFIT 
COMMON  /FI8/  TI ( 500 ) ,CCP( 500) .FLAG 
COMMON  /FI9/  PRESRES,VELH,UPISTON,XPISTON 
COMMON  /FIO/  TINC, EPS, TOUT 
COMMON  /Fll/  METH, MITER, KWRITE 

COMMON  /F12/  TMS,RMASSL,PRESRESN,PRESCH,RHOLN,BRPRES 
COMMON  /FI 3/  NPTS,IWRITE 
COMMON  /F14/  CD,CDC,RKNVIS 

COMMON  /F15/  NBFLAG,NPFLAG,NPIST,SPIST(20) ,RPIST(20) ,APIST(20) 
COMMON  /F16/  XPIST(IOOO) ,V0LF(1000) ,AVT(1000) ,ALIQ(1000) ,NGPTS 
COMMON  /F17/  XPISTC,IXPISTC,RLPRIMEO 
COMMON  /F18/  ISET,RM,RINTVS12 

COMMON  /F19/  RPl,RP2,RP3,RBl,RB2,RB3,VOL12,VOL23 
COMMON  /F20/  IFRL,RE,NGAP,SGAP(50) ,GAPW(50) 

COMMON  /F21/  RLBLTF,RLBLTS,NPRPTS,0RIGS3,0RIGS2.0RIGS1,X3,X2,X1,1P 
COMMON  /F22/  CUPISTON,CVELH,CXPISTON.CRMASSL 
COMMON  /F23/  IPRES ,RADDP,RADDB,RATIOP,RATIOB 
COMMON  /F24/  S3,S2,S1,RINTAR,RINTP3 

CHARACTER*80  TITLE 
CHARACTER*80  DATA 
CHARACTER*80  GECM 
CHARACTER*80  GRAF 
CHAR.^CTER*80  VPDIST 
INTEGER  TVENT,FLAG 

EXTERNAL  F 

INITIALIZING  COUNTERS  FOR  ARRAYS  AND  ENTRY  POINTS 
NPTS-0 
FLAG-1 
NBFLAG-1 
NPFLAG-1 
JFLAG-1 
IXPISTC-0 
I SET-0 

OUTPUT  TO  FILE  GIVEN  ON  COMMAND  LINE 

C  READ  INPUT  FORM  LI ST -DIRECTED  BATCH  RUN 
C  AND  ECHO  TO  PRINTER 

CALL  INPUT 
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READ  TIME-C  CH  PRES  BOUNDARY  CONDITIONS 
CALL  PRESCCH(l) 

READ  GEOMETRY 

IF  (TVENT.EQ.2)  CALL  B0LT2(1) 

SET  INITIAL  CONDITIONS 
CALL  STARTUP (Y.YDOT.N) 

SET  INTEGRATOR  PARAMETERS 
TO-O.O 
TOUT-TINC 
TMS-0 . 0 
HO-l.OE-03 
INDEX-1 
MSTATE-1 
LENW-1000 

FIRST  CALL  TO  DIFFERENTIAL  EQUATIONS 
CALL  F(N,0.0,Y,YDOT) 

FIRST  LINE  OF  OUTPUT 
CALL  CAPTION(IDIFEQN) 

CALL  OUT  (Y.YDOT) 

200  CALL  SDRIVl  (N,TO,Y,TOUT.MSTATE,EPS,WK,LENW) 

DIAGNOSTICS  BASED  ON  lER 
IF  (MSTATE.GT.2)  THEN 
WRITE  (*,500)  MSTATE 

500  FORMAT  (//, '  FATAL  ERROR- -MSTATE- ',15) 

WRITE  (*,505)  EPS,N,Y(1),Y(2).Y(3),Y(4) 

505  FORMAT('  EPS ,N, Y(l) , Y(2) , Y(3) . Y(4) : ' ,F10. 5 , 13 ,4F15 . 5) 
WRITE  (*,515)  TOUT, TO 
515  FORMATC  TOUT, TO: ' , 2F10 . 5) 

WRITE  (*,525)  YDOT(l),YDOT(2),YDOT(3),YDOT(4) 

525  FORMAT  ('  YDOT(l) , YDOT(2) ,YDOT(3) ,YDOT(4) : ' ,4F15 . 5) 
STOP 
ENDIF 

DIAGNOSTICS  BASED  ON  KWRITE 
IF  (KWRITE, EQ.l)  THEN 

WRITE  (*,505)  EPS,N,Y(1),Y(2),Y(3),Y(4) 

WRITE  (*,515)  TOUT, TO 

WRITE  (*,525)  YDOT(l) ,YDOT(2) ,YDOT(3) ,YDOT(4) 

ENDIF 

NOT  ALL  LIQUID  CAN  BE  INJECTED 
C  SINCE  BEHIND  AND  UNDER  PISTON 

C  APPROXIMATE  LIQUID  LEFT  AS  2.76  CC 
C  IF  LIQUID  MASS-2.76  OR  PISTON  TRAVEL-MAX  TRAVEL 

C  STOP  THE  INTEGRATOR 

C 

C  POSSIBLE  PISTON  TRAVEL  REMAINING  (PTR) 

PTR-RLMAX - XPI STON 

C 

IF  ((VOLFO.LE.2.76) .OR. (PTR.LE.0.01))  GOTO  300 
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TIMii  (TOUT)  IN  SECONDS  FOR  INTEGRATOR 
PRINTOUT  (TMS)  IN  MILLISECONDS 
TMS-TOUT*! . 0E3 
CALL  OUT  (Y.YDOT) 

TOUT-TOUT+TINC 
GOTO  200 
C 

C  300  IF  ((VOLFO.GT.2.76).AND.(PTR.LE.0.01))  WRITE(*,400) 

C  IF  ((PTR.GT.0.01) .AND.(VOLFO.LE.2.76))  WRITE(*,410) 

C 

300  TMS-TMS+TINC*! . 0E3 
CALL  OUT  (Y.YDOT) 

WRITE  (*,320)  NPTS 

320  FORMAT  (//,'  NUMBER  OF  POINTS  IN  GRAPHIC  FILE-', 15) 

C 

C  ERROR  MESSAGES 

C  400  FORMAT  (//,  '  LIQUID  MASS  REMAINS  BUT  PISTON  TRAVEL  COMPLETED';, 

C  410  FORMAT  (//, '  PISTON  TRAVEL  NOT  COMPLETED  BUT  NO  LIQUID  VOLUME') 

C 

C  CLOSING  FILES 

CLOSE  (16) 

CLOSE  (17) 

CLOSE  (19) 

STOP 

END 

C  ***************************************************** 

SUBROUTINE  INPUT 

C  DESCRIPTION  OF  LIQUID  CHAMBER  GEOMETRY 

COMMON  /NAMES/  TITLE, DATA, GRAF, GEOM,VPDIST 
COMMON  /FI 2/  AC,AP,AR,AL,IDIFEQN 
COMMON  /FI 3/  RLPRIME,RLVENT,RLMAX,RLTEMP,RLT 
COMMON  /FI4/  PMASS, OFFSET 

COMMON  /FI5/  TVENT,NROD,SROD(20) ,RR0D(20) ,AROD(20) ,JFLAG 
COMMON  /FI 6/  RHOL,RKl,RK2,VOLFO,PSI,AV 

COMMON  /FI7/  IFRP,NOPT,NFLOSS.FRICPOS(20) ,FLOSS(20) ,NFIT 

COMMON  /FI8/  TI(500) ,CCP( 500) , FLAG 

COMMON  /FI9/  PRESRES,VELH,UPISTON.XPISTON 

COMMON  /FIO/  TINC, EPS, TOUT 

COMMON  /Fll/  METH, MITER, KWRITE 

COMMON  /F12/  TMS, RMASSL,PRESRESN, PRES CH,RHOLN,BRPRES 
COMMON  /FI 3/  NPTS,IWRITE 
COMMON  /F14/  CD,CDC,RKNVIS 

COMMON  /F15/  NBFLAG,NPFLAG.NPIST,SPIST(20) ,RPIST(20) ,APIST(20) 
COMMON  /F16/  XPIST(IOOO) ,VOLF(1000) ,AVT(1000) ,ALIQ(1000) ,NGPTS 
COMMON  /F17/  XPISTC,IXPISTC,RLPRIMEO 
COMMON  /F18/  ISET,RM,RINTVS12 

COMMON  /F19/  RPl,RP2,RP3,RBl,RB2,RB3,VOL12,VOL23 
COMMON  /F20/  IFRL,RE,NGAP,SGAP(50) ,GAPW(50) 

COMMON  /F21/  RLBLTF,RLBLTS,NPRPTS,ORIGS3,ORIGS2,ORIGSl,X3,X2,Xl,IP 
COMMON  /F22/  CUPISTON,CVELH,CXPISTON,CRMASSL 
COMMON  /F23/  IPRES .RADDP , RADDB, RATIOP .RATIOB 

C 

CFARACTER*80  TITLE 
CHARACTER* 80  DATA 
CHARACTER*80  GEOM 
CHARACTER*80  GRAF 


CHARACTER*80  VPDIST 
INTEGER  TVENT.FLAG 
C 

C  INPUT  FROM  FILE  GIVEN  ON  COMMAND  LINE 
READ  (*,150)  TITLE 
WRITE  (*,150)  TITLE 
C  DESCRIPTION  OF  LIQUID  CHAMBER 
READ  (*,*)  AC.AP.AR 
WRITE  (*,20)  AC 
WRITE  (*,30)  AP 
WRITE  (*,40)  AR 
READ  (*,*)  RLPRIME,RLVENT 
WRITE  (*,50)  RLPRIME 
RLPRIMEO-RLPRIME 
WRITE  (*,60)  RLVENT 
READ  (*,*)  OFFSET 
WRITE  (*,65)  OFFSET 
READ  (*,*)  PMASS 
WRITE  (*,70)  PMASS 
READ  (*,*)  VOLFO 
WRITE  (*,120)  VOLFO 
C  DESCRIPTION  OF  BOLT 

C  IF  TVENT-1  THEN  STRAIGHT  BOLT 

C  IF  TVENT-2  THEN  REAL  BOLT  DESCRIBED  BY  RADIUS 
C  TVENT-2  USES  SEPARATE  FILE 

READ  (*,*)  TVENT 
WRITE  (*,80)  TVENT 
IF  (TVENT. EQ.l)  CALL  BOLTl(l) 

IF  (TVENT. EQ. 2)  THEN 
READ  (*,*)  RLTEMP 
WRITE  (*,82)  RLTEMP 
RLMAX-RLTEMP+RLPRIME 
WRITE  (*,84)  RLMAX 
ENDIF 

C  LIQUID  PROPELLANT  PROPERTIES 

READ  (*,*)  RH0L,RK1,RK2 
WRITE  (*,90)  RHOL 
WRITE  (*,100)  RKl 
WRITE  (*,110)  RK2 
RKl-RKl*! . 0E7 

C  FRICTION  LOSS  OF  LIQUID  (IFRL)  AND  PISTON  (IFRP) 
READ  (*,*)  IFRL 
WRITE  (*,130)  IFRL 
IF  (IFRL. EQ.l)  CA’L  FRICK 0,RLIQLOS) 

READ  (*,*)  IFRP 

WRITE  (*,140)  IFRP 

IF  (IFRP. EQ.l)  CALL  FRIC2(0 ,RPISLOS) 

C  NAME  OF  FILE  IN  WHICH  TIME -PR  BOUNDARY  COND  STORED 
READ  (*,160)  DATA 
WRITE  (*,170)  DATA 

C  NAME  OF  FILE  IN  WHICH  GEOMETRY  DATA  STORED 
IF  (TVENT. EQ. 2)  THEN 
READ  (*,160)  GEOM 
WRITE  (*,200)  GEOM 
ENDIF 

C  NAME  OF  FILE  IN  WHICH  GRAPH  DATA  STORED 
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READ  (*,160)  GRAF 
WRITE  (*.180)  GRAF 
C  INITIALIZE 

CALL  INITIAL 

C  PARAMETERS  FOR  INTEGRATOR 

CALL  NUMERIC 

C  DIFFERENTIAL  EQUATION  SET 

C  SET  1;  ORIGINAL  8/1/86 

C  SET  2:  REVISED  8/20/86 

C  SET  3:  BASELINE  WITHOUT  INERTIAL  TERMS 

READ  (*,*)  IDIFEQN 
WRITE  (*,190)  IDIFEQN 

SET  1.  INPUT  RADIUS  OF  PISTON  AT  STATIONS  1,2,3 
INPUT  RADIUS  OF  BOLT  AT  STATIONS  1,2,3 
INPUT  VOLUME  ENCLOSED  FROM  1-2  AND  2-3 
IWRITE-1,  DIAGNOSTICS  OUTPUT 
((IDIFEQN. EQ.l) .OR. (IDIFEQN . EQ . 2) )  THEN 
READ(*,*)  RP3,RP2,RP1 
WRITE(*,230)  RP3.RP2.RP1 
READ(*,*)  RB3,RB2.RB1 
WRITE(*.240)  RB3,RB2,RB1 
READ(*,*)  VOL12 
WRITE(*,250)  VOL12 
READ(*,*)  VQL23 
WRITE(*,260)  VOL23 
READ(*,*)  RLBLTF.RLBLTS 
WRITE(*,280)  RLBLTF.RLBLTS 
READ(*,*)  IWRITE 
WRITE(*,270)  IWRITE 
ENDIF 

C  IF  SET  3,  INPUT  REYNOLDS  NUMBER  AND  TABLE  OF  GAP  FOR  VENT 
IF  (IDIFEQN. EQ. 3)  THEN 
READ  (*,*)  RKNVIS 
WRITE  (*,210)  RKNVIS 
READ  (*,*)  NGAP 
DO  18  I-1,NGAP 

READ  (*,*)  SGAP(I) ,GAPW(I) 

WRITE  (*,220)  SGAP(I) ,GAPW(I) 

18  CONTINUE 
ENDIF 

C  OPTION  FOR  PRESSURE  DISTRIBUTION 
READ  (*,*)  IPRES 
WRITE  (*,145)  IPRES 
IF  (IPRES. EQ.l)  CALL  PRESDIS(l) 


20 

FORMAT 

(//,'  COMBUSTION  CHAMBER  AREA 

,F12 

30 

FORMAT 

(' 

PISTON  AREA--C  CH  SIDE 

.F12.5) 

40 

FORMAT 

(' 

PISTON  AREA- -RES  SIDE 

.F12.5) 

50 

FORMAT 

(’ 

LENGTH  L  PRIME 

.F12.5) 

60 

FORMAT 

(' 

LENGTH  OF  VENT 

.F12.5) 

65 

FORMAT 

(' 

PISTON  OFFSET 

m  * 

.F12.5) 

70 

FORMAT 

(' 

PISTON  MASS 

,F12.5) 

80 

FORMAT 

(//,'  VENT  OPTION 

-M6) 

82 

FORMAT 

(' 

STRAIGHT  LENGTH  OF  PIST 

.F12.5) 

84 

FORMAT 

(’ 

MAX  PISTON  TRAVEL 

.F12.5) 

90 

FORMAT 

(//,'  DENSITY  LIQUID 

,F12 

C  IF 

C 

C 

C  IF 

IF 
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100  FORMAT  ('  K1  -',F12.5) 

110  FORMAT  (’  K2  -',F12.5) 

120  FORMAT  ('  VOLUME  LIQUID  -',F12.5) 

130  FORMAT  (//, '  FRICTION  LOSS  LIQ  OPTION-', 16) 

140  FORMAT  (//,'  FRICTION  LOSS  PIS  OPTION-* ,16) 

145  FORMAT  (//,'  PR  DISTRIBUTION  OPTION  -',16) 

150  FORMAT(A) 

160  FORMAT (A) 

170  FORMAT  (//,'  TIME-C  CH  PRES  DATA  FILE:  ' ,A) 

180  FORMAT  (//, '  GRAPH  DATA  FILE:  '.A,//) 

190  FORMAT  (//,'  DIFFERENTIAL  EQUATION  SET. *,12) 

200  FORMAT  (//,'  GEOMETRY  DATA  FILE:  * ,A) 

210  FORMAT  (//, '  KINEMATIC  VISCOSITY  -',F12.5,/) 

220  FORMAT  ('  POSITION-' , F12 . 5 , lOX, '  GAP-',F12.5) 

230  FORMAT  (//,'  RAD  PIST3  -' , FIO . 5 , 5X, 'RAD  PIST2  -',F10.5,5X, 

+  'RAD  PISTl  -' ,F10.5) 

240  FORMAT  (//,'  RAD  BOLT3  -' ,F10 . 5 , 5X, 'RAD  BOLT2  -',F10.5,5X, 

+  'RAD  BOLTl  -' ,F10.5) 

250  FORMAT  (//,'  VOL  FUEL12-' , FIO . 5) 

260  FORMAT  ('  VOL  FUEL23-' , FIO . 5 ,/) 

270  FORMAT  ('  IWRITE  -',14.//) 

280  FORMAT  ('  FLAT  LEN  BOLT-' , F12 . 5 , '  SLANT  LEN  BOLT-' , F12 . 5) 
RETURN 
END 

C  ***************************************************7'.* 

SUBROUTINE  BOLTl (lOPT) 

STRAIGHT  BOLT 

MAX  PISTON  TRAVEL  CHOSEN  TO  AGREE  WITH  INITIAL  LIQUID  VOL 

COMMON  /FI2/  AC,AP,AR,AL,IDIFEQN 
COMMON  /FI 3/  RLPRIME,RLVENT,RLMAX,RLTEMP,RLT 
COMMON  /FI5/  TVENT,NROD,SROD(20),RROD(20),AROD(20),JFLAG 
COMMON  /FI6/  RHOL,RKl,RK2,VOLFO,PSI,AV 
COMMON  /FI 9/  PRESRES,VELH.UPISTON,XPISTON 
COMMON  /F12/  TMS,RMASSL,PRESRESN,PRESCH,RHOLN,BRPRES 

INTEGER  TVENT 

IF  IOPT-2  RECOMPUTE  VOLUME  TO  FIND  LIQUID  DENSITY 
IF  (IOPT.EQ.2)  GOTO  100 

OTHERWISE  READ  FROM  BATCH  RUNSTREAM  AND  FIND  MAX  PISTCN  TRAVEL 
C  AND  ORIGINAL  LENGTH  L  (RLTEMP)  VARYING  WITH  TIME 

READ  (*,*)  AV 
WRITE  (*,15)  AV 
RLMAX-VOLFO/ ( AR+AV ) 

WRITE  (*,10)  RLMAX 
RLTEMP-RLMAX - RLPRIME 
WRITE  (*,20)  RT.TEMP 
C 

C  AREA  OF  LIQUID 

AL-AR+AV 

C 

10  FORMAT  ('MAX  PISTON  TRAVEL  -',F12.5) 

15  FORMAT  ('CONSTANT  VENT  AREA  -',F12.5) 

20  FORMAT  ('ORIGINAL  L  IN  RES  -',F12.5) 
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GOTO  200 
C 

C  RECOMPUTING  VOLUME: (MAX  TRAVEL -TRAVEL)* (AREA  OF  LIQUID) 

C  SHOULD  CONSIDER  SLANT  ON  PISTON  HERE- -LATER 
C 

100  VOLFO-(RLMAX-XPISTON)*(AR+AV) 

RLT-RLTEMP - XPI STON 

LENGTH  L(T)  COLLAPSED  WHEN  L.E.  0.0001 
IF  (RLT.LE. 0.0001)  RLT-0.0 

IF  RLT  COLLAPSED,  RLPRIME  DECREASES 
IF  (RLT. EQ. 0.0)  RLPRIME-RLMAX- XPI STON 
IF  ( RLPRIME. LE. 0.1)  RLPRIME-0.0 

200  RETURN 
END 

***************************************************** 
SUBROUTINE  BOLT2(IOPT) 

BOLT  RADIUS  AS  FUNCTION  OF  PISTON  TRAVEL 

COMMON  /NAMES/  TITLE , DATA, GRAF, GEOM.VPDIST 
COMMON  /FI 2/  AC,AP,AR,AL,IDIFEQN 
COMMON  /FI 3/  RLPRIME, RLVENT,RLMAX,RLTEMP, RLT 
COMMON  /FI4/  PMASS, OFFSET 

COMMON  /FI5/  TVENT,NR0D,SR0D(20) ,RROD(20) ,AROD(20) ,JFLAG 
COMMON  /FI 6/  RHOL,RKl,RK2,VOLFO,PSI,AV 
COMMON  /FI7/  IFRP,NOPT,NFLOSS,FRICPOS(20) ,FLOSS(20) ,NFIT 
COMMON  /F18/  TI(500) ,CCP( 500) , FLAG 
COMMON  /FI9/  PRESRES,VELH,UP1ST0N, XPI STON 
COMMON  /FIO/  TINC, EPS, TOUT 
COMMON  /Fll/  METH, MITER, KWRITE 

COMMON  /FI 2/  TMS,RMASSL,PRESRESN,PRESCH,RHOLN,BRPRES 
COMMON  /F13/  NPTS,IWRITE 
COMMON  /F14/  CD,CDC,RKNVIS 

COMMON  /F15/  NBFLAG,NPFLAG,NPIST,SPIST(20) ,RPIST(20) ,APIST(20) 
COMMON  /F16/  XPIST(IOOO) ,VOLF(1000) ,AVT(1000) ,ALIQ(1000) ,NGPTS 
COMMON  /F17/  XPISTC,IXPISTC,RLPRIMEO 
COMMON  /F18/  ISET,RM,RINTVS12 

COMMON  /F19/  RPl,RP2,RP3,RBl,RB2,RB3,VOL12,VOL23 
COMMON  /F20/  IFRL,RE,NGAP,SGAP(50) ,GAPW(50) 

CHARACTER*80  TITLE 
CHARACTER*80  DATA 
CHARACTER*80  GEOM 
CHARACTER*80  GRAF 
CHARACTER*80  GEOMID 
CHARACTER*80  VPDIST 
INTEGER  '17ENT,FLAG 

IF  IOPT-2  INTERPOLATE  TO  FIND  VENT  AREA,  VOLUME  FUEL,  AREA  LIQ 
IF  (IOPT.EQ.2)  GOTO  150 

OPEN  GEOMETRY  FILE  AND  READ  ARRAY 

OPEN  ( 18, FILE-GEOM,IOSTAT-IOS,ERR-2, STATUS- 'OLD' ) 
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2  IF  (lOS.NE.O)  WRITE  (6,3)  lOS 

3  FORMAT ('  ERROR  OPENING  GEOM  FILE: ',110) 

REWIND (18) 

READ  (18,10)  GEOMID 
READ  (18,*)  NGPTS 
DO  50  I-l, NGPTS 

READ  (18,*)  XPIST(I),VOLF(I),AVT(I),ALIQ(I) 

50  CONTINUE 
CLOSE  (18) 

GOTO  200 
C 

C  IF  IOPT-2  READ  VOLFO,  AV,  AL  FROM  ARRAY 
C 

C  LOOKUP  RADIUS  OF  PISTON  AS  MEASURED  FROM  END  OF  PISTON 
150  IF  (XPISTON.LE.0.0)  XPISTON-0.0 
DO  60  I-l, NGPTS 

IF  (XPISTON.LE.XPIST(I))  GOTO  65 
60  CONTINUE 

IF  (I.GT.NGPTS)  THEN 

WRITE  (*,62)  XPISTON 
STOP 
ENDIF 

62  FORMAT  ('  ERROR  MESSAGE  FROM  BOLT2--I  >  NGPTS- -XPISTON-' ,F12 . 5) 
65  IF  (XPISTON. EQ.XPIST(I))  THEN 
VOLFO-VOLF(I) 

AV-AVT(I) 

AL-ALIQ(I) 

ELSE 

VOLFO-VOLF(I-1)+(VOLF(I)-VOLF(I-1))*((XPISTON-XPIST(I-1))/ 

+  (XPIST(I)-XPIST(I-l))) 

AV-AVT(I-1)+(AVT(I)-AVT(I-1))*((XPIST0N-XPIST(I-1))/ 

+  <XPIST(I)-XFIST(I-1;)) 

AL-ALIQ(I-l)+(ALIQ(I)-ALIQ(I-l))*((XPISTON-XPIST(I-l))/ 

+  (XPIST(I)-XPIST(I-l))) 

ENDIF 

LENGTHS  RLT  AND  RLPRIME 
RLT-RLTEMP -XPI STON 

LENGTH  L(T)  COLLAPSED  WHEN  L.E.  0.0001 
IF  (RLT. GE. 0.0001)  THEN 
GOTO  200 
ELSE 

RLT-0 . 0 

IXPISTC-IXPISTC+1 
ENDIF 

SAVE  XPISTC  FOR  ADJUSTING  RLPRIME 
IF  (IXPISTC.EQ.l)  XPISTC-XPISTON 

IF  RLT  COLLAPSED,  RLPRIME  DECREASES 

RLPRIME- (ORIGINAL  RLPRIME) - (DISTANCE  MOVED  THROUGH  RLPRIME) 
RLPRIME-RLPRIMEO- (XPI STON -XPISTC) 

COLLAPSE  RLPRIME 

IF  (RLPRIME. LE. 0.001)  RLPRIME-0.0 
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IF  (RLPRIME.EQ.0.0)  THEN 
WRITE  (*,180) 

STOP 

ENDIF 

180  FORMAT  ('  MESSAGE  FROM  B0LT2- -RLPRIME-0- -TRAVEL  COMPLETE') 

C 

10  FORMAT  (A) 

200  RETURN 
END 

C  ***************************************************** 

SUBROUTINE  FRICl(IOPT.RLIQLOS) 

C 

FRICTION  LOSS  ASSOCIATED  WITH  LIQUID 
COMPUTES  INLET  LOSS 

COMMON  /FI 3/  RLPRIME,RLVENT,RLMAX,RLTEMP,RLT 
COMMON  /FI6/  RHOL,RKl,RK2,VOLFO,PSI,AV 
COMMON  /FI9/  PRESRES,VELH,UPISTON,XPISTON 
COMMON  /FIV  CD.CDC.RKNVIS 
COMMON  /F20/  IFRL,RE,NGAP,SGAP(50) ,GAPW(50) 

IOPT-0  ON  FIRST  CALL- -READS  INPUT 
IOPT-1  TO  COMPUTE  LOSS  IN  DIF  EQUATIONS 

IF  (lOPT.EQ.l)  GOTO  50 

READ  (*,*)  PSI 
WRITE  (*.100)  PSI 
READ  (*,*)  RKNVIS 
WRITE  (*,110)  RKNVIS 
READ  (*,*)  NGAP 
DO  10  I-1,NGAP 

READ  (*,*)  SGAP(l) ,GAPW(I) 

WRITE  (*,120)  SGAP(I),GAPW(I) 

10  CONTINUE 

FIND  DIAMETER  OF  VENT  (GAP) 

50  DO  60  I-l.NGAP 

IF  (XPISTON.EQ.SGAP(I))  THEN 
GAP-GAPW(I) 

ELSE 

GAP-GAPW(I-1)+(GAPW(I)-GAPW(I-1))*((XPIST0N-SGAP(I-1))/ 
+  (SGAP(I)-SGAP(I-l))) 

ENDIF 
60  CONTINUE 

REYNOLDS  NUMBER  COMPUTED  AND  ABS  VALUE  TAKEN 
RE-ABS (VELH*2 . *GAP/RKNVIS ) 

COMPUTE  LIQUID  LOSS 
IF  (RE.EQ.0.0)  THEN 

RLIQL0S-1.+(1./PSI-1.)*(1-/PS1-1.) 

GOTO  200 

ELSE 

RLIQLOS-l.+(l./PSI-l. )*(i./PSI-l.) 

+  +( .3164*RLVENT)/((RE**.25)*2.*GAP) 

ENDIF 
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100  FORMAT  ('  PSI-- INLET  LOSS  -'.F12.5) 

110  FORMAT  ('  KINEMATIC  VISCOSITY  -',F12.5) 

120  FORMAT  (’  POSITION-' , F12 . 5 , lOX, '  GAP-',F12.5) 

200  RETURN 
END 

***************************************************** 
SUBROUTINE  FRIC2(I0PT,RPISL0S) 

FRICTION  LOSS  ASSOCIATED  WITH  PISTON 

COMMON  /FI7/  IFRP,NOPT,NFLOSS,FRICPOS(20),FLOSS(20),NFIT 
COMMON  /FI9/  PRESRES.VELH.UPISTON.XPISTON 

IOPT-0  ON  INPUT;  IOPT-1  ON  OUTPUT 
IF  (lOPT.EQ.l)  GOTO  500 

IF  NOPT-1  USE  A  TABLE  OF  PISTON  POS  VS  FRICTION  LOSS 
IF  NOPT-2  COMPUTE  FRICTION  AS  FCN  OF  PISTON  VELOCITY 
READ(*,*)  NOPT 

CHECKING  VALUE  OF  NOPT 
IF  ((NOPT.NE.l) .AND. (NOPT.NE.2))  THEN 
WRITE(*,5) 

5  FORMAT ('  ERROR  IN  NOPT  FROM  FRIC2') 

STOP 

ENDIF 

GOTO  (100,200)  NOPT 

100  READ  (*,*)  Nn/)SS 
WRITE  (*,20)  NITjOSS 
DO  10  I-l,NFLOSS 

READ  (*,*)  FRICPOS(I) ,FLOSS(I) 

WRITE  (*,30)  FRICPOS(I) ,FLOSS(l) 

10  CONTINUE 

READ  (*,*)  NFIT 
WRITE  (*,40)  NFIT 

GOTO  800 

IF  NOPT-2  WILL  USE  FRIC-(OPPOSITE  SIGN  OF  UPISTON)*B*(V**N) 
CALL  B  THE  COEF  AND  N  THE  EXPONENT 
200  READ  (*,*)  COEF, EXP 
WRITE  (*,50)  COEF 
WRITE  (*,60)  EXP 

GOTO  800 

NOPT-1  USES  TABLE;  NOPT-2  USES  FCN  OF  PISTON  VEL 
500  IF  (NOPT.EQ.2)  GOTO  600 

DETERMINE  FRICTION  LOSS  FROM  INTERPOLATED  VALUE 

IF  (XPISTON.GE.FRICPOS(NFLOSS))  THEN 
RPISLOS-FLOSS(NFLOSS) 

ELSE 

CALL  DVDINT(XPISTON, RPISLOS , FRICPOS , FLOSS , NFLOSS , NFIT) 


ENDIF 

C 

GOTO  800 
C 

C  DETERMINE  FRICITON  LOSS  FROM  RELATION 
C  FRICTION-(OPPOSITE  SIGN  OF  PISTON  VEL)*B*UPISTON''N 

C 

600  IF  (UPISTON.EQ.0.0)  THEN 
RPISLOS-0.0 
GOTO  800 

ENDIF 

SIGN— 1 . * (UPISTON/ (ABS (UPISTON) ) ) 

RPISLOS-SIGN*COEF*( (ABS(UPISTON) )**EXP) 

C 

20  FORMAT  ('  NO.  OF  PTS  FOR  FRIG  LOSS-' ,15) 

30  FORMAT  ('  PISTON  POSITION-' ,F12. 5, '  FRICTION  LOSS-' , E12 . 5) 
40  FORMAT  {'  NO.  OF  PTS.  USED  FOR  INTERPOLATION: ' ,13) 

50  FORMAT  ('  COEF  OF  PIS  FRIG  -',E12.5) 

60  FORMAT  ('  EXP  OF  PIS  FRIG  -',F12.5) 

800  RETURN 
END 

C  ***************************************************** 

SUBROUTINE  INITIAL 
C  SETS  INITIAL  CONDITIONS 

COMMON  /FI9/  PRESRES,VELH, UPISTON, XPISTON 
READ  (*,*)  PRESRES.VELH, UPISTON, XPISTON 
WRITE  (*,10)  PRESRES 
WRITE  (*,20)  VELH 
WRITE  (*,30)  UPISTON 
WRITE  (*,40)  XPISTON 
C  CONVERT  FROM  MPA  TO  CGS  SYSTEM 
PRESRES-PRESRES*! . 0E7 

10  FORMAT  ('  INITIAL  PR  IN  RESERVOIR  -',F12.5) 

20  FORMAT  ('  INITIAL  VEL  IN  VENT  -',F12.5) 

30  FORMAT  ('  INITIAL  PISTON  VELOCITY  =',F12.5) 

40  FORMAT  ('  INITIAL  PISTON  POSITION  -',F12.5) 

RETURN 

END 

C  ***************************************************** 

SUBROUTINE  NUMERIC 
C  PARAMETERS  FOR  INTEGRATOR 

C  INTEGRATOR  DGEAR  FROM  IMSL 

COMMON  /FIO/  TINC, EPS, TOUT 
COMMON  /Fll/  METH, MITER, KWRITE 
C 

READ  (*,*)  TINC, EPS 
READ  (*,*)  METH, MITER, KWRITE 
WRITE  (*,10)  TINC 
WRITE  (*,20)  EPS 
WRITE  (*,30)  METH 
WRITE  (*,40)  MITER 
WRITE  (*,50)  KWRITE 
C 

10  FORMAT  ('  INTEGRATOR- -TINC  -',F12.5) 

20  FORMAT  ('  INTEGRATOR- -EPS  -',F12.5) 

30  FORMAT  ('  INTEGRATOR- -METH  -',16) 
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40  FORMAT  ('  INTEGRATOR- -MITER  -’,16) 

50  FORMAT  ('  INTEGRATOR- -KWRITE  »',I6) 

RETURN 

END 

C  *-v*************************************************** 

SUBROUTINE  STARTUP  (Y.YDOT.N) 

SETS  INITIAL  MATRIX  Y  FOR  INTEGRATOR 
SETS  INITIAL  YDOT 
DIMENSION  Y(4) ,YD0T(4) 

COMMON  /FI 6/  RHOL,RKl,RK2.VOLFO,PSI,AV 
COMMON  /FI9/  PRESRES.VELH.UPISTON.XPISTON 
COMMON  /F12/  TMS,RMASSL,PRESRESN,PRESCH.RHOLN,BRPRES 
COMMON  /F22/  CUPISTON.CVELH.CXPISTON.CRMASSL 

LOADING  ARRAY  Y 
Y(l)  IS  VELOCITY  OF  PISTON 
Y(1)=UPIST0N 

Y(2)  IS  VELOCITY  OF  LIQUID  IN  VENT 
Y(2)-VELH 

Y(3)  IS  POSITION  OF  PISTON 
Y(3)-XPIST0N 
Y(4)  IS  MASS  OF  LIQUID 
RMASSL-RHOL*VOLFO 
Y(4)-RMASSL 
N-4 

CUPISTON-0 . 0 
CVELH-0 . 0 
CXPISTON-0.0 
CRMASSL-0.0 
YDOT(l)-CUPISTON 
YDOT(2)-CVELH 
YDOT(3)>=CXPISTON 
YD0T(4)-CRMASSL 

RETURN 
END 

St*****-************-*********************************** 

SUBROUTINE  F(N, TIME, Y, YDOT) 

CALLS  THE  SET  OF  DIFFERENTIAL  EQUATIONS  UNDER  CONSIDERATION 
DIMENSION  Y(4),YD0T(4) 

COMMON  /NAMES/  TITLE, DATA, GRAF, GEOM.VPDIST 
COMMON  /FI2/  AC,AP,AR,AL,IDIFEQN 
COMMON  /FI 3/  RLPRIME,RLVENT,RLMAX,RLTEMP,RLT 
COMMON  /FI4/  PMASS,UFFSEX 

COMMON  /FI5/  TVENT,NROD,SROD(20) ,RR0D(20) ,AROD(20) ,JFLAG 
COMMON  /FI 6/  RH0L,RK1,RK2,V0LF0,PSI,AV 
COMMON  /FI 7/  IFRP,NOPT,NFLOSS,FRICPOS(20) ,FLOSS(20) ,NFIT 
COMMON  /FI8/  TI(500) ,CCP( 500) , FLAG 
COMMON  /FI9/  PRESRES,VELH,UPISTON,XPISTON 
COMMON  /Flo/  TINC, EPS, TOUT 
COMMON  /Fll/  METH, MITER, KWRITE 
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COMMON  /F12/  TMS,RMASSL,PRESRESN.PRESCH,RH0LN,BRPRES 
COMMON  /F13/  NPTS.IWRITE 
COMMON  /F14/  CD.CDC.RKNVIS 

COMMON  /F15/  NBFLAG,NPFLAG,NPIST,SP1ST(20) ,RPIST(20) ,APIST(20) 
COMMON  /F16/  XPIST(IOOO) ,VOLF(1000) ,AVT(1000) ,ALIQ(1000) ,NGPTS 
COMMON  /F17/  XPISTC.IXPISTC.RLPRIMEO 
COMMON  /F18/  ISET,RM.RINTVS12 

COMMON  /F19/  RPl,RP2,RP3,RBl,RB2,RB3,VOL12,VOL23 
COMMON  /F20/  IFRL.RE.NGAP, SGAP(50) , GAPW(50) 

COMMON  /F21/  RLBLTF,RLBLTS,NPRPTS,ORIGS3,ORIGS2,ORIGSl,X3,X2,Xl.IP 
COMMON  /F22/  CUPISTON.CVELH.CXPISTON.CRMASSL 
COMMON  /F23/  1 PRES ,RADDP,RADDB,RATIOP, RATIOS 
COMMON  /F24/  S3 , S2 , SI ,RINTAR,RINTP3 
C 

CHARACTER*80  TITLE 
CHARACTER*80  DATA 
CHARACTER*80  GEOM 
CHARACTER*80  GRAF 
CHARACTER*80  VPDIST 
INTEGER  TVENT.FLAG 

IF  (IDIFEQN.EQ.l)  CALL  DIFFEQNl(N,TIME,Y,YDOT) 

RETURN 

END 

C  ****************************************************** 

SUBROUTINE  PRESCCH(IOPT) 

C 

C  CREATES  TIME- -COMB  CH  PRESSURE  BOUNDARY  CONDITION 

C  FROM  THE  DATA  FILE  LISTED  IN  THE  BATCH  RUN 
C 

COMMON  /NAMES/  TITLE, DATA, GRAF, GEOM, VPDIST 
COMMON  /FI8/  TI ( 500) ,CCP(500) , FLAG 
COMMON  /FIO/  TINC, EPS, TOUT 

COMMON  /F12/  TMS,RMASSL,PRESRESN,PRESCH,RHOLN,BRPRES 

COMMON  /F15/  NBFLAG,NPFLAG,NPIST,SPIST(20) ,RPIST(20) ,APIST(20) 

C 

CHARACTER*80  TITLE 
CHARACTER*80  DATA 
CHARACTER*80  GEOM 
CHARACTER*80  GRAF 
CHARACTER*80  VPDIST 
CHARACTER*80  I DENT 
INTEGER  FLAG 
C 

C  ARRAY  IS  FILLED  FROM  DATA  FILE 
C  IF  IOPT-2  C  CH  PRES  IS  INTERPOLATED  FROM  TABLE 

C 

IF  (IOPT.EQ.2)  GOTO  100 
C 

C  FILLING  ARRAY  FROM  DATA  FILE 

OPEN  (16, FILE-DATA, STATUS- 'OLD' , lOSTAT-IOS , ERR-10) 

REWIND (16) 

10  IF  (lOS.NE.O)  WRITE  (6,20)  lOS 

20  FORMAT  ('  ERROR  OPENING  TIME-C  CH  PRES  FILE', 110) 

READ  (16,30)  IDENT 
WRITE  (*,40)  IDENT 
READ  (16,*)  IPOINTS 
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DO  50  I-1,IP0INTS 

READ  ( 16, *,ERR-60, END-70)  TI(I),CCP(I) 

C 

C  CHANGE  TIME  TO  SECONDS 

C  CHANGE  PRESSURE  FROM  MPA  TO  CONSISTENT  UNITS  WITH  CGS  SYSTEM 
C  BY  MULTIPLYING  BY  1.0E7  CONVERSION  CONSTANT 
TI(I)-TI(I)*1.0E-3 
CCP(I)-CCP(I)*1.0E7 
50  CONTINUE 
GOTO  70 
30  FORMAT  (A) 

40  FORMAT  (//,'  TIME-PRES  IDENT: ' .A,//) 

60  WRITE  (6,80) 

80  FORMAT  ('  ERROR  READING  TIME-C  CH  PRES  FILE') 

70  CLOSE  (16) 

GOTO  400 

INTERPOLATING  TO  FIND  C  CH  PRES 
100  IF  (NPFLAG.EQ.l)  THEN 
TMS 1-0.0 
NPFLAG-2 
ELSE 

TMSl-TMS*! . OE- 3+TINC 
ENDIF 

DO  200  I-FLAG,500 

IF  (TMSl.LE.TI(I))  GOTO  300 
200  CONTINUE 

300  IF  (TMSl.EQ.TI(I))  THEN 
FLAG-I 

PRESCH-CCP(I) 

ELSE 

FLAG-I -1 

PRESCH-CCP(I-1)+(CCP(I)-CCP(I-1))* 

+  ((TMS1-TI(I-1))/(TI(I)-TI(I-1))) 

ENDIF 

400  RETURN 
END 

***************************************************** 

SUBROUTINE  DVDINT (X , FX , XT , FT , NP , ND) 

INTERPOLATES  A  VALUE  OF  Y  AS  A  FUNCTION  OF  X 
USING  ANY  ORDER  OF  INTERPOLATION 
FROM  LIBRARY 
X:  THE  SENT  VALUE  OF  X 

FX:  THE  INTERPOLBTED  VALUE  OF  Y  TO  BE  RETURNED 
XT:  AN  ARRAY  OF  X  VALUES 
FT:  A  CORRESPONDING  ARRAY  OF  Y  VALUES 
NP:  NUMBER  OF  POINTS  IN  THE  ARRAYS 

ND:  NUMBER  OF  POINTS  TO  BE  USED  FOR  THE  INTERPOLATING  POLYNOMIAL 
TWO  PTS  FOR  LINEAR,  THREE  FOR  QUADRATIC,  ETC. 

CAUTION:  CHECK  TO  SEE  IF  THE  VALUE  OF  X  IS  OUTSIDE  THE  ARRAY 
BEFORE  ENTERING  THE  SUBROUTINE 

DIMENSION  XT(NP) ,FT(NP) ,T(16) 
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N-ND 

31  Nl-(N-l)/2 

N2-N/2 
N3-NP-N2+1 
IF(NP-N)30,41,41 

41  N4-N1+2 
IF(XT(1)-XT(2))22.80.60 

22  COirriNUE 

IF(X-2.*XT(1)+XT(2))20,20,21 
21  IF(X-2.*XT(NP)+XT(NP-1))441,441,20 

441  IF(NP.LT.10)GO  TO  42 
N5-NP-N 
443  N5-N5/2 

N6-N4+N5 

IF(XT(N6) .LT.X)N4-N6 
IF(N5.GT.l)GO  TO  443 

42  IF(X-XT(N4))45,43,43 

43  IF(N4-N3)44,45,44 

44  N4-N4+1 
GOTO  42 

45  N4-K4-1 
N5-N4-N1 
D046I-1.N 
T(I)-FT(N5) 

46  N5-N5+1 
L-(N+l)/2 
TR-T(L) 

N6-N4 

N7-N4+1 

JU-1 

N2-N-1 

UN-1.0 

D012J-1,N2 

N5-N4-N1 

N3-N-J 

D09I-1,N3 

N8-N5+J 

T(1)-(T(I+1)-T(I))/(XT(N8)-XT(N5)) 

9  N5-N5+1 

GOTO(10,11),JU 
CALL  GOTOER 

10  UN-UN*(X-XT(N6)) 

JU-2 

N6-N6-1 
GOTO  12 

11  UN-UN*(X-XT(N7)) 

JU-1 

N7-N7+1 

I^L-1 

12  TR-TR+UN*T(L) 

FX-TR 

RETURN 

20  WRITE  (*,50)  X,XT(1) ,XT(NP) 

STOP 

50  FORMATC  ARG.  NOT  IN  TABLE  X-',E14.7 

1  E14.7,'  XT(NP)-' ,E14.7,2X, '  DVDINT') 


'  XT(1) 
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30  WRITE  (*,51)  NP,ND 

51  FORMATC  TABLE  TOO  SMALL  NP=',I5,'  ND=  ',I5,2X,'  DVDINT') 

STOP 

60  IF(X-2.*XT(1)+XT(2))61,20,20 

61  IF(X-2.*XT(NP)+XT(NP-1))20.721,721 

721  IF(NP.LT.10)GO  TO  72 

N5-NP-N 
723  N5-N5/2 

N6-N4+N5 

IF(XT(N6)  .GT.X)  N4>=N6 
IF(N-5.GT.l)  GO  TO  723 

72  IF(X-XT(N4))  73,73,45 

73  :f;N4-N3)  74,45,74 

74  N4-N4+1 
GOTO  72 

80  WRITE  (*,52)  XT(1) 

STOP 

52  FORMATC  CONSTANT  TABLE  XT( 1 )=' , E14 . 7 , 2X, '  DVDINT') 

END 

C  *************************  ****************************** 

SUBROUTINE  GOTOER 
C 

WRITE(*,10) 

10  FORMATC/,'  ERROR  IN  COMPUTED  GOTO- -TERMINATING ' ) 

STOP 

END 

C  St**************************************************** 

SUBROUTINE  CAPTION (IDIFEQN) 

C  CAPTION  ON  OUTPUT  TABLE 

IF  ( (IDIFEQN. EQ.l) .OR. (IDIFEQN. EQ. 2))  THEN 
WRITE  (*,10) 

10  FORMATC IX, 'TIME' ,5X, 'CH  PR' , 2X , 2X, ' LIQ  PR' , 2X, 2X, ' BRCH  PR', IX, 
-‘2X,  'LIQ  VEL'  , 

+1X,4X, 'AV' ,4X,4X, 'RHO' ,3X,1X, 'LIQ  VOL' , IX, IX, ' LIQ  MASS', IX, 
-(-2X,'PIST  POS' ,1X,1X, 'PIST  VEL' ,1X,4X, 'CD' ) 

WRITE(*,20) 

20  FORMATC/, IX, ' (MS) ' ,5X, ' (MPA) ' ,2X,3X, ' (MPA) ' ,2X,3X, ' (MPA) ' ,2X, 
+2X, ' (CM/S) ' ,2X, 

+2X, ' (CM**2) ' ,2X,1X, ' (G/CC) ' ,2X,3X, ' (CC) ' ,3X,3X, ' (G) ' ,4X, 

+3X, ' (CM) ' ,3X,2X, ' (CM/S) ' ,2X,/) 

ELSE  IF  (IDIFEQN. EQ. 3)  THEN 
WRITE  (*,30) 

30  FORMAT (IX, 'TIME' ,5X, 'CH  PR’ , 2X, 2X, ' LIQ  PR' , 2X , 2X , ' LIQ  VEL’ , 
+1X,4X, 'AV' ,4X,4X, 'RHO' ,3X,1X, 'LIQ  VOL’ , IX, IX, 'LIQ  MASS' ,1X. 
+2X,'PIST  POS' , IX, IX, 'PIST  VEL' ,1X,4X, 'CD' ,4X,4X. 'CDC' ) 
WRITE(*,40) 

40  FORMATC/, IX, ' (MS) ' ,5X, ' (MPA) ' ,2X,3X, ' (MPA) ' ,2X,2X, ' (CM/S) ' ,2X, 
+2X, ' (CM**2) ' ,2X,1X, ' (G/CC) ' ,2X,3X, ’ (CC) ' , 3X. 3X, ’ (G) ' ,4X, 

+3X, ' (CM) ' ,3X,2X, ' (CM/S) ' ,2X,/) 

ENDIF 

C 

RETURN 

END 

r,  **************************  **********************5i********* 

SUBROUTINE  OUT  (A,ADOT) 

C  OUTPUT  TABLE  OF  RESULTS 
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DIMENSION  A(4),AD0T(4) 

COMMON  /NAMES/  TITLE, DATA, GRAF. GEOM.VPDI ST 
COMMON  /FI 2/  AC,AP.AR,AL,IDIFEQN 
COMMON  /FI 3/  RLPRIME.RLVENT,RLMAX,RLTEMP,RLT 
COMMON  /FI4/  PMASS, OFFSET 

COMMON  /FI5/  TVENT.NROD,SROD(20) ,RROD(20) ,AROD(20) ,JFLAG 
COMMON  /FI 6/  RHOL,RKl,RK2.VOLFO,PSI,AV 

COMMON  /FI7/  IFRP,NOPT.NFLOSS.FRICPOS(20) ,FLOSS(20) ,NFIT 

COMMON  /FI8/  TI(500) ,BCP(500) .FLAG 

COMMON  /FI9/  PRESRES.VELH.UPISTON.XPISTON 

COMMON  /FIO/  TINC.FPS.TOUT 

COMMON  /Fll/  METH, MITER, KWRITE 

COMMON  /F12/  TMS.RMASSL.PRESRESN.PRESCH.RHOLN.BRPRES 
COMMON  /F13/  NPTS.IWRITE 
COMMON  /F14/  CD.CDC.RKNVIS 

COMMON  /F15/  NBFLAG,NPFLAG.NPIST.SPIST(20) ,RPIST(20) ,APIST(20) 
COMMON  /F16/  XPIST(IOOO) .VOLF(IOOO) .AVT(IOOO) ,ALIQ(1000) .NGPTS 
COMMON  /F17/  XPISTC.IXPISTC.RLPRIMEO 
COMMON  /F18/  ISET,RM,RINTVS12 

COMMON  /F19/  RPl,RP2,RP3.RBl.RB2,RB3,VOL12,VOL23 
COMMON  /F20/  IFRL,RE,NGAP,SGAP(50) ,GAPW(50) 

COMMON  /F21/  RLBLTF,RLBLTS,NPRPTS.0R1GS3,0RIGS2,0RIGS1,X3,X2,X1,IP 
COMMON  /F22/  CUPISTON , CVELH , CXPISTON , CRMASSL 
COMMON  /F23/  IPRES ,RADDP,RADDB,RATIOP,RATIOB 
COMMON  /F24/  S3 , S2 , SI ,RINTAR,RINTP3 
C 

CHARACTER*80  TITLE 
CHARACTER*80  DATA 
CHARACTER*80  GEOM 
CHARACTER*80  GRAF 
CHARACTER*80  VPDIST 
INTEGER  TVENT.FLAG 

CALL  TO  EQUATIONS  TO  SET  ALL  VARIABLES  AT  CURRENT  PISTON 
C  VELOCITY.  Liq  VEL,  PISTON  POSITION,  LIQ  MASS 
C  ON  FIRST  STEP  WRITE  INITIAL  CONDITIONS 

IF  ((TMS.GT.O.LE-7) .AND. (IDIFEQN.EQ. 1)) 

+  CALL  DIFFEQNl(N,TIME,A,ADOT) 

C 

C  CONVERTING  PRESSURE  TO  MPA 

PRESRESN-PRESRESN* ( 1 . OE -  7 ) 

PRESCH-PRESCH* ( 1 . OE - 7 ) 

BRPRES-BRPRES* ( 1 . OE- 7 ) 

C 

C  WRITING  TO  PRINTER 

IF  ((IDIFEQN.EQ.l) .OR. (IDIFEQN.EQ. 2))  THEN 

WRITE(*,10)  TMS,FRE3CH,PRESRESN,BRPRES,A(2) ,AV, 

4  RH0LN,V0LF0,A(4) ,A(3) ,A(1) ,CD 

10  FORMAT(F5.2,11F10.3) 

NPTS-NPTS+1 
ENDFILE  (6) 

CALL  GRAFFILE(A,ADOT) 

C 

ELSE  IF  (IDIFEQN.EQ. 3)  THEN 
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C  INCLUDE  COMPARISON  DC-V3/SQRT(2*(P1-P3)/RH0) 

WRITE ( * , 20 )  TMS , PRESCH , PRESRESN . A( 2 ) , AV , RHOLN , VOLFO . 

+  A(4),A(3),A(1).CD,CDC 

20  F0RMAT(F5.2,11F10.3) 

NPTS-NPTS+1 
CALL  GRAFFILE(A,ADOT) 

ENDIF 

CALL  PRESSURE  DISTRIBUTION  OUTPUT  IF  IPRES-1 
IF  (IPRES.EQ.l)  THEN 
CONVERT  PRESSURE  BACK  TO  CCS  SYSTEM 
PRESRESN-PRESRESN*( 1 . OE+7 ) 

PRESCH-PRESCH*<;  1 .  OE+7  ) 

BRPRES-BRPRES* ( 1 . OE+7 ) 

CALL  PRESDIS(2) 

ENDIF 

DIAGNOSTICS  IF  IWRITE-1 
IF  (IWRlTE.EQ.l)  THEN 

UPISTON-A(l) 

VELH-A(2) 

XPISTON-A(3) 

RMASSL-A(4) 

SLOPE  OF  PISTON  BACK  FACE 
RM- (RPl - RP2 ) /RLPRIME 

LENGTHS  OF  RESERVOIR  AT  time  TMS 
RLl 3-RLPRIME+RLVENT 
RL03-RLT+RL13 

VOLUME  IN  REGION  1-2  DECREASES  WHEN  RLT-0.0 
IF  (RLT.EQ.0.0)  VOL12-VOLFO-VOL23 
VOL13-VOL12+VOL23 
C 

WRITE (* ,  90 )  CUPISTON ,  CVELH ,  CXPISTON , CRM/.SSL 
90  FORMAT ('  CUPISTON-' ,G12 . 5 , '  CVELH-' ,G12 . 5 , '  CXPISTON=' , 
+  G12.5,'  CRMASSL-' ,G12.5) 

C 

ENDIF 

RETURN 

END 

C  **+*********************+**************************** 

SUBROUTINE  GKAFFILE(A, ADOT) 

C  CREATES  FILE  TL  USE  FOR  GRAPHING 
C  ORDER  OF  VARIABLES  SAME  AS  IN  SUBROUTINE  OUT 

C 

DIMENSION  A(4),AD0T(4) 

COMMON  /NAMES/  TITLE, DATA, GRAF, GEOM.VPDIST 
COMMON  /FI 2/  AC,AP,AR,AL,IDIFEQN 

COMMON  /FI5/  TVENT,NROD,SROD(20) ,kROD(20) ,ARCD(20) ,JFLAG 
COMMON  /FI 6/  RHOL,RKl,RK2,VOLFO,PSI,AV 
COMMON  /FI9/  PRESRES,VELH,UPISTON,XPISTON 
COMMON  /F12/  TMS, RMASSL, PRESRESN, PRESCH, RHOLN, BRPRES 
COMMON  /F13/  NPTS.IWRITE 
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COMMON  /F14/  CD.CDC.RKNVIS 
C 

CHARACTER*80  TITLE 
CHARACTER*80  DATA 
CHARACTER*80  GEOM 
CHARACTER*80  GRAF 
GHARACTER*80  VPDIST 
INTEGER  TVENT 
C 

IF  (NPTS.EQ.l)  OPEN(17.FILE-GRAF,IOSTAT-IOS,ERR-10) 

G 

IF  ((IDIFEQN.EQ.l) .OR. (IDIFEQN.EQ.2))  THEN 

WRITE(17,30)  TMS,PRESCH.PRESRESN,BRPRES,A(2) ,AV, 

+  RH0LN,V0LF0,A(4) ,A(3) ,A(1) ,CD 

ENDFILE  (17) 

ELSE  IF  (IDIFEQN.EQ.3)  THEN 

WRITE (17,30)  TMS , PRESCH , PRESRESN , A ( 2 ) , AV , RHOLN , VOLFO , 

+  A(4).A(3),A(1),CD.CDC 

ENDIF 
GOTO  40 
C 

10  IF  (lOS.NE.O)  WRITE  (6,20)  lOS 

20  FORMATC  ERROR  OPENING  FILE  FOR  GRAPH  DATA', 110) 

30  FORMAT(F5.2,11F10.3) 

C 

40  RETURN 
END 

C  ********************************************************* 

SUBROUTINE  DIFFEQN1(N,TIME,Y,YD0T) 

VALUES  OF  DERIVATIVES  OF  PISTON  VEL,  VEL  OF  LIQUID  IN  VENT, 
POSITION  OF  PISTON,  MASS  OF  LIQUID 

DIMENSION  Y(4),YD0T(4) 

COMMON  /NAMES/  TITLE, DATA, GRAF, GEOM, VPDIST 
GOMMON  /FI2/  AC , AP , AR, AL, IDIFEQN 
COMMON  /FI 3/  RLPRIME,RLVENT,RLMAX,RLTEMP,RLT 
COMMON  /FI4/  PMASS, OFFSET 

COMMON  /FI5/  TVENT, NROD, SROD(20) ,RROD(20) ,AROD(20) ,JFLAG 
COMMON  /FI6/  RHOL,RKl,RK2,VOLFO,PSI,AV 
COMMON  /FI7/  IFRP,NOPT,NFLOSS,FRICPOS(20) ,FL0SS(20) ,NFIT 
COMMON  /FI8/  TI (500) ,CCP( 500) .FLAG 
COMMON  /FI9/  PRESRES.VELH.UPISTON.XPISTON 
COMMON  /FIO/  TINC, EPS, TOUT 
COMMON  /Fll/  METH, MITER, KWRITE 

COMMON  /F12/  TMS, RMASSL, PRESRESN. PRESCH, RHOLN, BRPRES 
COMMON  /F13/  NPTS.IWRITE 
COMMON  /F14/  CD.CDC.RKNVIS 

COMMON  /F15/  NBFLAG,NPFLAG,NPIST,SPIST(20) ,RPIST(20) ,APIST(20) 
COMMON  /F16/  XPIST(IOOO) ,VOLF( 1000) ,AVT( 1000) ,ALIQ( 1000) .NGPTS 
COMMON  /FI 7/  XPISTC,IXPISTC,RLPRIMEO 
COMMON  /F18/  ISET,RM,RINTVS12 

COMMON  /F19/  RPl,RP2,RP3.RBl,RB2,RB3,VOL12,VOL23 
COMMON  /F20/  IFRL,RE,NGAP,SGAP(50) ,GAPW(50) 

COMMON  /F2 1/  RLBLTF , RLBLTS , NPRPTS , ORIGS3 , ORIGS2 , ORIGS 1 , X3 , X2 , XI , I P 
COMMON  /F22/  CUPISTON.CVELH.CXPISTON.CRMASSL 
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COMMON  /F23/  I PRES .RADDP.RADDB, RATIO?, RATIOS 
COMMON  /F2V  S3,S2,S1.RINTAR,RINTP3 
C 

CHARACTER*80  TITLE 
CHARACTER*80  DATA 
CHARACTER*80  GEOM 
CHARACTER*80  GRAF 
CHARACTER*80  VPDIST 
INTEGER  TVENT.FLAG 
C 

PARAMETER  (PI-3.141592654) 

C 

EXTERNAL  FAREA , FAI lA , FIA . FAIVA , FVA , FAIVA2 , FXA , FV2A , FVOL , FVA2 
C 

C  FINAL  VALUES  OF  INTEGRALS:  RI--- 

C  INTERMEDIATE  VALUES  OF  INTEGRALS:  RIN--- 

C  FUNCTIONS  TO  EVALUATE  INTEGRANDS;  F . 

C 

C  PASSING  ARRAY  Y  TO  VARIABLES 

C  VELOCITY  OF  PISTON 

UPISTON-Y(l) 

C  VELOCITY  OF  LIQUID  IN  VENT 

VELH-Y(2) 

C  POSITION  OF  PISTON 

XPISTON-Y(3) 

C  MASS  OF  LIQUID 

RMASSL-Y(4) 

C  VOLUME  OF  FUEL  DEPENDENT  UPON  PISTON  POSITION 

C  IF  TVENT-1  THEN  STRAIGHT  BOLT 

C  IF  TVENT-2  THEN  LOOKUP  GEOMETRY  RECORDED  IN  FILE 
C  FROM  BOLTGEO.FOR  (C630MM.DAT) 

C  //IOPT-2  TO  FIND  VOLUME, 

(VOLFO) ,  AREA  OF  VENT  (AV) ,  AREA  OF  LIQUID  (AL) , 
RECOMPUTE  LENGTH  RLT,  RECOMPUTE  LENGTH  RLPRIME 

IF  (TVENT.EQ.l)  CALL  BOLTl(2) 

IF  (TVENT.EQ.2)  CALL  BOLT2(2) 

DENSITY  OF  LIQUID 
RHOLN-RMAS  SL/VOLFO 

PRESSURE  IN  LIQUID  RESERVOIR 

PRESRESN-PRESRES+(RK1/RK2)*( (RHOLN/RHOL)**RK2-l . ) 

C 

C  PRESSURE  IN  COMBUSTION  CHAMBER  IS  FOUND  BY  T\3LE 
C  LOOKUP  OF  BOUNDARY  CONDITIONS 

C  IOPT-2  TO  READ  FROM  TABLE 

C 

CALL  PRESCCH(2) 

C 

C  ORIGINAL  POSITIONS  ON  PISTON  AND  BOLT  WITH  ZERO 
C  AT  THE  BACK  WALL  AND  POSITIVE  TOWARD  THE  FRONT 
C  OF  THE  BOLT 

ORIGS 3-RLMAX+RLVENT 
ORIGS2-ORIGS3-RLVENT 
ORIGS1-ORIGS2 -RLPRIME 


76 


oo  non  no  nooono  non  on  on 


X3-ORIGS3+OFFSET 
X2-X3-RLBLTF 
X1-X2-RLBLTS 

DIFFERENCE  IN  RADII  IN  PISTON  AND  BOLT  SLANTS 
RADDP-RP2 -RPl 
RADDB-RB2-RB1 

RATIOS  GIVING  SLOPE  OF  SLANT  SECTIONS 
RATIOP-RADDP/RLPRIME 
RATIOB-RADDB/RLBLTS 

RLMAX  IS  MAX  PISTON  DISP  AND  DOES  NOT  INCLUDE  VENT 
SETTING  CURRENT  LOCATIONS  OF  POINTS  ON  PISTON 
S3-ORIGS3-XPISTON 
S2-ORIGS2-XPISTON 
Sl-ORIGSl-XPISTON 

AREA  OF  BACK  WALL 
AW-PI*(RP1*RP1-RB1*RB1) 

FORCE  ON  COMBUSTION  CHAMBER  SIDE  MUST  BE  GREATER 
THAN  FORCE  ON  LIQUID  RESERVOIR  SIDE 
BEFORE  PISTON  CAN  MOVE 
IF  (PRESCH.LE. 45692100.0)  THEN 
CUPISTON-0.0 
CVELH-0 . 0 
CXPISTON-0.0 
CRMASSL-0.0 
CVELS P-0.0 
CPOSSP-0.0 
BRPRES-PRESRESN 
GOTO  300 
ENDIF 

TIME  DERIVATIVE  OF  VENT  AREA 
IF  ((X1.LT.S3) .AND. (S3.LT.X2))  THEN 
CAV-2 . *PI*BLTRAD(S3)*UPISTON*RATIOB 
ELSE 

CAV-0 . 

ENDIF 

INTEGRAL  K1 

INTEGRAL  FROM  0  TO  S3  l./A(X,T) 

CALL  QR0M0(F1A,S1,S3,RIN1A) 

RIlA-Sl/AW+RINlA 

INTEGRAL  K2 

C  INTEGRAL  FROM  0  TO  S3  OF  A(X.T)  TIMES  INTEGRAL  FROM 
C  0  TO  X  OF  l./A(X,T) 

C  BOOK  5,  P  81  (38,39) 

IF  (X1.LT.S3)  THEN 

CALL  QROMO(FAREA,Sl,S3,RINA) 

CALL  QR0M0(FAI1A,S1,S3,RINA1A) 
RIDAlA-Sl*Sl/2.+Sl*RINA/AW+RINAlA 
ELSE  IF  (S3.LE.X1)  THEN 
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CALL  QR0M0(FAREA,S1,S2,RINA) 

CALL  QR0M0(FAI1A,S1,S2,RINA1A) 

CALL  QR0M0(F1A,S1,S2,RIN1A) 

RIDAlA-Sl*Sl/2 . +S1*RINA/AW+RINA1A 
f-  +AV*S1*(S3-S2)/AW+AV*RIN1A*(S3-S2)+(S3-S2)*(S3-S2)/2. 

ENDIF 

INTEGRAL  K3 

INTEGRAL  FROM  0  TO  S3  OF  V(X,T)*V(X,T)/A(X,T) 

CALL  QROMO(FV2A,Sl,S3,RINV2A) 

RIV2A-AW*Sl*Sl*Sl/3 .+RINV2A 

INTEGRAL  K4 

INTEGRAL  FROM  0  TO  S3  OF  V(X,T)/A(X,T) 

CALL  QR0M0(FVA,S1,S3,RINVA) 

RIVA-Sl*Sl/2 . +RINVA 

INTEGRAL  K5 

INTEGRAL  FROM  0  TO  S3  OF  X*A(X,T) 

CALL  QR0M0(FXA,S1,S3,RINXA) 

RIXA-AW*Sl*Sl/2 . +RINXA 

INTEGRAL  K6 

INTEGRAL  FROM  0  TO  S3  OF  A(X,T)  TIMES  INTEGRAL  FROM 
0  TO  X  OF  V(X,T)/A(X,T) 

CALL  QROMO ( FAREA , S 1 , S  3 , RINA) 

CALL  QROMO ( FAIVA , S 1 , S 3 , RINAVA) 

RIDAVA-AW*Sl*Sl*Sl/6 . +Sl*Sl*RINA/2 .+RINAVA 

INTEGRAL  K7 

INTEGRAL  FROM  0  TO  S3  V(X,T) 

CALL  QR0M0(FV0L,S1,S3,RINV) 

RIV-Sl*Sl*AW/2 .+RINV 

INTEGRAL  K8 

INTEGRAL  FROM  0  TO  S3  OF  A(X.T)  TIMES  INTEGRAL  FROM 
0  TO  X  OF  V(X,T)/[A(X,T)*A(X,T)I 
CALL  QROMO (FAREA, SI, S3, RINA) 

CALL  QROMO ( FAI VA2 , S 1 , S  3 , RI AVA2 ) 

RIDVA2-S 1*S l*Sl/6.+Sl*S 1*RINA/ ( 2 . *AW) +RI AVA2 

INTEGRAL  K9 

INTEGRAL  FROM  0  TO  S3  OF  V(X,T)/[A(X.T)*A(X,T) ] 

CALL  QROMO ( FVA2 , S 1 , S  3 , RINVA2 ) 

RIVA2-S 1*S 1/ ( 2 . *AW) +RINVA2 

TERMS  USED  BELOW 

Zl- ( VELH*AV -UPI STON*AR) /VOLFO 

Z2-(VELH+CAV+AV*CVELH 

+  .AR*CUPIST0N+Z1*UPIST0N*(AR+AV) )/V0LF0 
COEFFICIENTS  OF  INTEGRALS 

CK1-RH0LN*AW*AW*UPIST0N*(UPIST0N/(2 . *VOLFO) ) +RH0LN*Z1*AW*UPI STON 
CK2-- 1 .*RHOLN*Z1*(AR+AV)*(UPISTON/VOLFO) 

CK3-RHOLN*Zl* ( Zl/ ( 2 . *VOLFO) ) 
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CK4-RH0LN*AW*Z1*(UPIST0N/V0LF0)-RH0LN*CAV*(VELH/V0LF0) 

+  -Z1*RH0LN*(AR+AV)*(UPIST0N/V0LF0) 

CK5-RH0LN*Z1* (UPISTON/VOLFO) 

CK6-RH0LN*CAV*(VELH/(V0LF0*V0LF0) ) 

+  +Z1*RH0LN*(AR+AV)*(UPIST0N/(V0LF0*V0LF0) ) 

CK7— 1 .*RH0LN*Z1*(UPIST0N/V0LF0) 

CK8-- 1 . *RH0LN*Z1*(UPIST0N/V0LF0) 

CK9-RH0LN*UPIST0N*Z1 

TVA-- 1 . *RHOLN*UPISTON*AW*UPISTON*AW/ ( 2 . *AV*AV) 

+  -RHOLN*VOLFO*VOLFO*Z1*Zl/(2 . *AV*AV) 

+  -RH0LN*UPIST0N*AW*V0LF0*Z1/ (AV*AV) 

+  +RH0LN*UPIST0N*V0LF0*Z1/AV 

+  -RH0LN*UPIST0N*Z1*S3 

CONTINUITY  EQN 

SCKC-CK1*RI1A+CK2*RIDA1A+CK3*RIV2A+CK4*RIVA+CK5*RIXA 
+  +CK6*RIDAVA+CK7*RIV+CK8*RIDVA2+CK9*RIVA2+TVA 

CUDOTC—  1 .  *RH0LN*AW*RI1A+RH0LN*AW*RIDA1AA0LF0 
+  - RHOLN*RIXA/VOLFO - RHOLN*AR*RI DAVA/ ( VOLFO*VOLFO ) 

+  +RH0LN*S3+RH0LN*AR/V0LF0 

CVDOTC=RHOLN*AV*RIDAVA/ (VOLFO*VOLFO) -RHOLN*AV*RIVA/VOLFO 

BREECH  PRESSURE 

PRX2- (UPISTON*RI lA) * (RHOLN*AW*AW) * (UPI STON/ ( 2 . *VOLFO) ) 

PRX3- (RH0LN*AW*RIDA1A)  *  (CUPISTONAOLFO  ) 

PRX4- . 5*RH0LN*UPIST0N*UPIST0N 

PRX5- (RH0LN*Z1*Z1*RIV2A) / ( 2 . *VOLFO) 

PRX6-(RH0LN*Z1*AW*RIVA)*(UPIST0NA0LF0) 

PRX7- (RHOLN*RIXA) * ( CUPISTON AOLFO) 

PRX8-(RHOLN*Z2*RIDAVA) AOLFO 
PRX9-(RHOLN*Z1*RIV)*(UPISTONAOLFO) 
PRX10-(RHOLN*Z1*AW*RIDA1A)*(UPISTONAOLFO) 
PRX11-(RH0LN*Z1*RIDVA2)*(UPIST0NA0LF0) 

PRX26- (RH0LN*Z1*RIXA) * (UPISTON AOLFO ) 

BRPRES-PRESRESN+PRX2+PRX3 - PRX4+PRX5+PRX6 - PRX7+PRX8 - PRX9 - PRXIO 
+  -PRX11+PRX26 

TERMS  IN  MOMENTUM  EQUATIO 
CMK7-RH0LN*CAV*  (  VELH  AOLFO  ) 

+  +RHOLN*(AR+AV)*Z1*(UPISTONAOLFO)  -RH0LN*Z1*Z1 

TIME  DERIVATIVE  OF  K7 
DELK7— 1 . *AW*S3*UPISTON 
TMK7-CMK7*RIV+RH0LN*Z1*DELK7 

MOMENTUM  EQUATION 

SAM-PRESCH* ( AP+AV) - BRPRES*AW+RHOLN*AV*VELH*VELH 
+  +(  - 1 .  *AW*RHOLN+RHOLN*(AR+AV)+RHOLN*S3*AW*/^RAOLFO 

+  -RHOLN*AR)*UPISTON*UPISTON 

+  +( - 1 . *RHOLN*AV*AW*S3 AOLFO+RHOLN*AV)*UPISTON*VELH 

+  +TMK7 
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CUDOTM-PMAS  S - AW*RHOLN*S  3+RHOLN*VOLFO+AR*RHOLN* ( RI V/VOLFO ) 
CVDOTM-AV*RHOLN* (RIV/VOLFO) 

C 

C  DETERMINE  FRICTION  LOSSES 

C  IF  IFRL-1  CONSIDER  LIQUID  FRICTION 

C  IF  IFRP-1  CONSIDER  PISTON  FRICTION  FROM  INPUT  TABLE 

C  IF  IFRP-2  CONSIDER  PISTON  FRICTION  FROM  FR-(-+)B*V^N 

IF  (IFRL.EQ.l)  CALL  FRIC1(1 .RLIQLOS) 

IF  (IFRP.EQ.l)  CALL  FRIC2 ( 1 .RPISLOS) 

C 

C  CHANGE  IN  PISTON  VELOCITY 

CUPI STON- ( CVDOTM/ ( CUDOTC*CVDOTM+CUDOTM*CVDOTC ) ) * 

+  ( (PRESCH-PRESRESN) -SCKC+SAM*CVDOTC/CVDOTM) 

C 

C  CHANGE  IN  LIQUID  VEL  IN  VENT 

CVELH- ( CVDOTM/ ( CUDOTC*CVDOTM+CUDOTM*CVDOTC ) ) * 

+  ( (PRESCH-PRESRESN) -SCKC+SAM*CVDOTC/CVDOTM)* 

+  ( CUDOTM/CVDOTM ) - S AM/CVDOTM 

C 

C  CHANGE  IN  POSITION  OF  PISTON 

CXPISTON-UPISTON 
C 

C  CHANGE  IN  MASS  OF  LIQUID 
CRMASSL=- 1 . *RHOLN*AV*VELH 
C 

C  DISCHARGE  COEFFICIENT  (USING  V3-VEUI  AND  BREECH  PRES) 

IF  (PRESRESN.GT.PRESCH)  THEN 

CD-VELH/ ( SQRT ( 2* ( PRESRESN - PRESCH) /RHOLN ) ) 

ELSE 

CD-0 . 0 
END  IF 
C 

300  CONTINUE 

C  FILLING  ARRAY  YDOT 

C  YDOT(l)  IS  CHANGE  IN  PISTON  VELOCITY 

YDOT(l)-CUPISTON 

C  YDOT(2)  IS  CHANGE  IN  LIQUID  VEL  IN  VENT 
YDOT(2)-CVELH 

C  YDOT(3)  IS  CHANGE  IN  POSITION  OF  PISTON 
YDOT(3)-CXPISTON 

C  YD0T(4)  IS  CHANGE  IN  MASS  OF  LIQUID 
YDOT(4)-CRMASSL 
RETURN 
END 

C  ******************************************************************* 

SUBROUTINE  PRESDIS (lOPT) 

C 

C  COMPUTES  VELOCITY  AND  PRESSURE  DISTRIBUTION  IN  LIQUID  RESERVOIR 

C  INTEGRATION  OF  AREA  AND  VOLUME  INTEGRALS  USED 
C  IN  PRESSURE  DISTRIBUTION 

C  USING  ROMBERG  INTEGRATION  WITH  REFINEMENT  OF  MIDPOINT  RULE 

C 

C  FINAL  VALUES  OF  INTEGRALS:  RI--- 
C  INTERMEDIATE  VALUES  OF  INTEGRALS:  RIN- - - 
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C  FUNCTIONS  TO  EVALUATE  INTEGRANDS:  F . 

COMMON  /NAMES/  TITLE, DATA, GRAF. GEOM.VPDI ST 

COMMON  /FI 2/  AC,AP,AR,AL,IDIFEQN 

COMMON  /FI 3/  RLPRIME.RLVENT,RLMAX,RLTEMP,RLT 

COMMON  /FI4/  PMASS, OFFSET 

COMMON  /FI 6/  RHOL,RKl,RK2.VOLFO,PSI,AV 

COMMON  /FI9/  PRESRES,VELH,UPISTON,XPISTON 

COMMON  /FIO/  TINC, EPS, TOUT 

COMMON  /F12/  TMS,RMASSL,PRESRESN,PRESCH,RHOLN,BRPRES 
COMMON  /F19/  RPl,RP2.RP3,RBl,RB2,RB3,VOL12,VOL23 
COMMON  /F21/  RLBLTF,RLBLTS.NPRPTS,ORIGS3,ORIGS2,ORIGSl,X3,X2,Xl,IP 
COMMON  /F22/  CUPISTON,CVELH,CXPISTON, CRMASSL 
COMMON  /F23/  IPRES,RADDP,RADDB.RATIOP, RATIOS 
COMMON  /F2V  S3,S2,S1,RINTAR,RINTP3 
COMMON  /F25/  I 
C 

CHARACTER*80  TITLE 

CHARACTER*80  DATA 

CHARACTER*80  GRAF 

CHARACTER*80  GEOH 

CHARACTER*80  VPDIST 

PARAMETER  (PI-3 . 141592654 ,NDIV-100) 

C 

EXTERNAL  FAREA , FAI lA , FlA , FAIVA , FVA , FAIVA2 , FXA , FV2A , FVOL , FVA2 
C 

C  COMPUTES  PRESSURE  DISTRIBUTION  ACROSS  LIQUID  RESERVOIR 
C  USING  LAGRANGE  ASSUMPTIONS 

C 

C  READ  INPUT  IF  IOPT-1  AND  SET  CONSTANTS 
C  CONSTANTS  SET  ON  FIRST  CALL 

IF  (IOPT.EQ.2)  GOTO  100 

INPUT  BOLT  FLAT  LENGTH  AND  SLANT  LENGTH 
READ  (*,*)  RLBLTF.RLBLTS 
WRITE  (*,40)  RLBLTF.RLBLTS 

INPUT  NO.  PTS  FOR  PR  DIST  AND  OPTION  TO  OPEN  GRAPH  FILE 
READ  (*,*)  NPRPTS.IP 
WRITE  (*,50)  NPRPTS.IP 
IF  (IP.EQ.l)  THEN 
READ  (*,70)  VPDIST 
WRITE  (*,80)  VPDIST 
ENDIF 

ORIGINAL  POSITIONS  ON  PISTON  AND  BOLT  WITH  ZERO 
AT  THE  BACK  WALL  AND  POSITIVE  TOWARD  THE  FRONT 
OF  THE  BOLT 
ORIGS  3-RLMAX+RLVENT 
ORIGS  2-ORIGS  3 -RLVENT 
ORIGS1-ORIGS2-RLPRIME 
X3-ORIGS3+OFFSET 
X2-X3-RLBLTF 
X1-X2-RLBLTS 

DIFFERENCE  IN  RADII  IN  PISTON  AND  BOLT  SLANTS 
RADDP-RP2-RP1 
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RADDB-RB2 -RBI 


RATIOS  GIVING  SLOPE  OF  SLANT  SECTIONS 

RATIOP-RADDP/RLPRIME 

RATIOB-RADDB/RLBLTS 

GOTO  300 

SET  VALUES  OF  X  FOR  WHICH  PRESSURE  IS  EVALUATED 
RLMAX  IS  MAX  PISTON  DISP  AND  DOES  NOT  INCLUDE  VENT 
THUS,  HAVE  TO  ADD  RLVENT  TO  OBTAIN  PRESSURE  IN  VENT 


SET  VALUES  OF  X  FOR  WHICH  PRESSURE  IS  EVALUATED 
RLMAX  IS  MAX  PISTON  DISP  AND  DOES  NOT  INCLUDE  VENT 
THUS,  HAVE  TO  ADD  RLVENT  TO  OBTAIN  PRESSURE  IN  VENT 

CONSTANTS  AT  EACH  TIMESTEP 

SETTING  CURRENT  LOCATIONS  OF  POINTS  ON  PISTON 
100  S3-ORIGS3-XPISTON 
S2-ORIGS2-XPISTON 
Sl-ORIGSl-XPISTON 

AREA  OF  BACK  WALL 
AW-PI*(RP1*RP1-RB1*RB1) 

TIME  DERIVATIVE  OF  VENT  AREA 
IF  ((X1.LT.S3) .AND. (S3.LT.X2))  THEN 
CAV-2 . *PI*BLTRAD (S3) *UPISTON*RATIOB 
ELSE 

CAV-0 . 

ENDIF 

TERMS  USED  BELOW 
Zl- ( VELH*AV - UPI STON*AR ) /VOLFO 
Z2- ( VELH+CAV+AV*CVELH 

+  -AR*CUPIST0N+Z1*UPIST0N*(AR+AV) ) /VOLFO 

INTEGRAL  FROM  0  TO  S3  OF  A(X,T)  TIMES  INTEGRAL  FROM 
0  TO  X  OF  l./A(X,T) 

IF  (X1.LT.S3)  THEN 

CALL  QROMO(FAREA,Sl,S3,RINA) 

CALL  QR0M0(FAI1A,S1,S3,RINA1A) 

RIDAlA-Sl*Sl/2 . +S1*RINA/AW+RINA1A 
ELSE  IF  (S3.LE.X1)  THEN 

CALL  QROMO(FAREA,Sl,S2,RINA) 

CALL  QR0M0(FAI1A,S1,S2,RINA1A) 

CALL  QR0M0(F1A,S1,S2,RIN1A) 

RIDAlA-Sl*Sl/2 . +S1*RINA/AW+RINA1A 
+  +AV*Sl*(S3-S2)/AW+AV*RINlA*(S3-S2)+(S3-S2)*(S3-S2)/2. 

ENDIF 
C 

C  INTEGRAL  FROM  0  TO  S3  OF  A(X,T)  TIMES  INTEGRAL  FROM 
C  0  TO  X  OF  V(X,T)/A(X,T) 

CALL  QROMO(FAREA,Sl,S3 ,RINA) 
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CALL  QR0M0(FAIVA,S1,S3,RINAVA) 
RIDAVA-AW*Sl*Sl*Sl/6 . +Sl*Sl*RINA/2 . +RINAVA 

INTEGRAL  FROM  0  TO  S3  OF  V(X.T)/A(X,T) 

CALL  QROMO ( FVA , S 1 , S  3 , RINVA) 

RIVA-Sl*Sl/2 . +RINVA 

INTEGRAL  FROM  0  TO  S3  OF  A(X,T)  TIMES  INTEGRAL  FROM 
0  TO  X  OF  V(X,T)/[A(X.T)*A(X,T)] 

CALL  QROMO (FAREA, SI. S3, RINA) 

RIDVA2-S 1*S 1*S 1/6 . +S 1*S 1*RINA/ ( 2 . *AW) +RI AVA2 

INTEGRAL  FROM  0  TO  S3  OF  X*A(X,T) 

CALL  QR0M0(FXA,S1.S3,RINXA) 

RIXA-AW*Sl*Sl/2 . +RINXA 

INTEGRAL  FROM  0  TO  S3  OF  V(X,T)*V(X,T)/A(X.T) 

CALL  QROMO(FV2A.Sl,S3,RIMV2A) 

RIV2A-AW*Sl*Sl*Sl/3 .+RINV2A 

INTEGRAL  FROM  0  TO  S3  l./A(X,T) 

CALL  QR0M0(F1A,S1,S3,RIN1A) 

RIIA-SI/AW+RINIA 

INTEGRAL  FROM  0  TO  S3  V(X,T) 

CALL  QROMO(FVOL,Sl,S3,RINV) 

RIV-Sl*Sl*AW/2 . +RINV 

STEP  SIZE 
STEP-S3/REAL(NDIV) 

LOOPING 

X-0.0 

NPTS-NDIV+1 
DO  400  I=1,NPTS 
IF  (I.EQ.NPTS)  X-S3 
VELOCITY  DISTRIBUTION 
VOLATX-FVOL(X) 

AREA-FAREA(X) 

VELATX-UP I STON* ( AW - AREA ) /AREA+ ( VELH*AV - UPI STON*AR ) 

+  *(1./V0LF0)*(V0LATX/AREA) 

IF  (X.EQ.O.)  THEN 
RIVAX-0 . 

RIVA2X-0 . 

RIlAX-0. 

GOTO  500 
END  IF 

INTEGRAL  FROM  0  TO  X  OF  V(X,T)/A(X,T) 

IF  (X.LE.Sl)  THEN 
RIVAX-X*X/2 . 

ELSE  IF  (X.GT.Sl)  THEN 

CALL  QROMO (FVA, SI, X, RINVA) 

RIVAX-S1*S1/:.  t-RINVA 
ENDIF 
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INTEGRAL  FROM  0  TO  X  OF  V(X,T)/[A(X,T)*A(X,T) ] 

IF  (X.LE.Sl)  THEN 
RIVA2X=X*X/ ( 2 . *AW) 

ELSE  IF  (X.GT.Sl)  THEN 

CALL  QROMO ( FVA2 . S 1 , X , RINVA2 ) 

RIVA2X-S 1*S 1/ ( 2 . *AW) +RINVA2 
ENDIF 

INTEGRAL  FROM  0  TO  X  OF  l./A(X,T) 

IF  (X.LE.Sl)  THEN 
RIIAX-X/AW 

ELSE  IF  (X.GT.Sl)  THEN 

CALL  QROMO (FlA.Sl.X.RINlAX) 

RI lAX-S 1/AW+RINlAX 
ENDIF 

PRESSURE  DISTRIBUTION 

500  PRX2-(UPISTON*RIlA)*(RHOLN*AW*AW)*(UPISTON/(2 .*VOLFO) ) 

PRX3- ( RHOLN*AW*RIDAlA ) * ( CUP I STON/VOLFO ) 
PRX5-(RH0LN*Z1*21*RIV2A) / ( 2 . *VOLFO) 

PRX6- (RHOLN*Zl*AW*RIVA) * (UPISTON/VOLFO) 

PRX7= (RHOLN*RIXA) * ( CUPISTON/VOLFO) 

PRX8= (RHOLN*Z2*RIDAVA) /VOLFO 
PRX9-(RHOLN*Zl*RIV)*(UPISTON  'VOLFO) 

PRXIO- (RH0LN*Z1*AW*RIDA1A)  *(.  UPISTON/VOLFO) 

PRXll- (RH0LN*Z1*RIDVA2 )* (UPISTON/VOLFO) 

PRX12-( (RH0LN*AW*AW)/(2 . *AREA*AREA) )*(UPISTON*UPISTON) 
PRX14-(RHOLN*VOLATX*VOLATX*Zl*Zl)/(2 . *AREA*AREA) 

PRX16-( (RH0LN*AW*Z1*V0LATX)/(AREA*AREA) )*UPISTON 
PRXl 7- ( ( RH0LN*Z1*V0LATX) /AREA) *UPI STON 
PRX18-(-RHOLN*AW*CUPISTON+RHOLN*Zl*UPISTON*AW)*RIlAX 
PRX2 l-RHOLN*X*CUPI STON 
PRX22-RHOLN*Z2*RIVAX 
PRX24=RHOLN*Zl*RIVA2X*UPISTON 
PRX25-RHOLN*Zl*X*UPISTON 
PRX26-(RHOLN*Zl*RIXA)*(UPISTON/VOLFO) 

PRESXT-PRESRESN+PRX2+PRX3+PRX5+PRX6 - PRX7+PRX8 - PRX9 - PRXIO 
+  - PRXll - PRX12 - PRX14 - PRX16+PRX17+PRX18+PRX2 1 

+  -PRX22+PRX24-PRX25+PRX26 

CON^VERTING  PRESSURE  TO  MPA 
PRESXT-PRESXT+ ( 1 . OE- 7 ) 

OPEN  FILE  FOR  OUTPUT 
IF  (IP.EQ.l) 

+  CALL  GRAFDIS(VPDIST,I,TMS,X,VELATX,PRESXT,AREA,VOLATX) 

PRINTOUT  OF  LOCATION, VELOCITY, PRESSURE. AREA, VOLUME  TO  PRINTER 
C  PRINTOUT  AT  BACK  WALL  AND  AT  EXIT 
WRITE(*,5) 

WRITE  (*,10)  X,VELATX,PRESXT,AREA,VOLATX 
ENDIF 

IF  (I.EQ.NPTS)  WRITE(*,10)  X , VELATX , PRESXT , AREA , VOLATX 
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C  PRINT  DISTRIBUTION  OF  POINTS 
J-NDIV/NPRPTS 
XI-REAL(I) 

XJ-REAL(J) 

IF  ((INT(XI-INT(XI/XJ)*XJ)) .EQ.O) 

+  WRITE  (*,10)  X,VELATX,PRESXT,AREA,VOLATX 

INCREMENT  A  STEP 
X-X+STEP 

400  CONTINUE 

5  FORMAT  (/,18X, 'X' ,19X, 'VEL' ,18X, 'PRES' .19X, 'AREA' ,18X, 'VOL' ) 
10  FORMAT  (10X.F12.5,10X.F12.5,10X,F12.5,10X,F12.5,10X,F12.5) 

30  FORMAT  (lOX, F12 . 5 . 10X,F12 . 5. lOX, F12 . 5 , 10X,F12 . 5 , 10X,F12 . 5 ,/) 
40  FORMAT  ('  FLAT  LEN  BOLT-' ,F12.5, '  SLANT  LEN  BOLT-' , F12 . 5) 

50  FORMAT  ('  NO.  OF  PTS  FOR  DIST-' . 16 , 5X, '  IP-', 15) 

60  FORMAT  ('  PISRAD-' , F12 . 5 , lOX, '  BLTRAD-' , F12 . 5 , lOX, 

+'  LIQAREA-' ,F12.5) 

70  FORMAT  (A) 

80  FORMAT  (/,'  VEL,  PRES  DIST  DATA  FILE;  '.A) 

300  RETURN 
END 

************************************************* 

SUBROUTINE  GRAFDIS (VPDIST , I , TMS , X , VELATX , PRESXT , AREA , VOLATX) 

CREATES  FILE  OF  VEL,  PRES  DISTRIBUTION  TO  USE  FOR  GRAPHING 
ORDER  OF  VARIABLES  SAME  AS  IN  SUBROUTINE  PRESDIS 

FILE  19:  TIME 

X  VEL(X)  PRES(X)  AREA(X)  VOL(X) 

FILE  20:  SPECIFIC  TIMES  TO  SIMPLIFY  GRAPHING 

CHARACTER*80  VPDIST 

OPEN  FILE  ON  FIRST  CALL 
IF  ((TMS.EQ.0.0) .AND. (I.EQ.l)) 

+  OPEN  (19,FILE-VPDIST,IOSTAT-IOS,ERR-10) 

WRITE  LINE  1:  TIME  FOR  EACH  NEW  TIME 

LINE  2;  TIME,  NO.  OF  COL  (USE  FOR  DISSPLA) 

IF  (I.EQ.l)  THEN 

WRITE(19,30)  TMS 
WRITE(19,35)  TMS 
35  FORMAT (F20. 8, 5X, '  5') 

ENDIF 
C 

10  IF  (IOS.NE.0.0)  WRITE  (6,20)  lOS 
20  FORMAT('  ERROR  OPENING  DIST  FILE: ',110) 

30  FORMAT(/,'  TIME-' , Fll . 5) 

40  FORMAT  (F12 . 5 , 3X, F12 . 5 , 3X, F12 . 5 , 3X, F12 . 5 , 3X, F12 . 5) 

C 

RETURN 

END 

C  *******************************************  , ******** 
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FUNCTION  IFHEAV(Y,X) 


HEAVISIDE  FUNCTION  ACTING  AS  A  SWITCH 
SWITCH-Y-X 

IF  (SWITCH. GE.O)  THEN 
IFHEAV-1 

ELSE 

IFHEAV-0 

ENDIF 

RETURN 

END 

***********ic-k****ie-k*-k***-k-k-k****ieie*-k-k*-k********** 

FUNCTION  PISRAD(X) 

FINDS  RADIUS  OF  PISTON  AT  ANY  POSITION  X  AT  A  GIVEN  TIME 
WHICH  FIXES  S1,S2,S3  RELATIVE  TO  BOLT 


COMMON  /FI6/  RHOL.RKl,RK2.VOLFO.PSI,AV 

COMMON  /FI9/  RPl,RP2,RP3,RBl.RB2,RB3,VOL12,VOL23 

COMMON  /F2i/  RLBLTF,RLELTS,NPRPTS,0RIGS3.0RIGS2,0RIGS1,X3,X2,X1,IP 

COMMON  /F23/  IPRES .RADDP .RADDB .RATIOP.RATIOB 

COMMON  /F24/  S3 . S2 , 31 ,RINTAR,RINTP3 

PISRAD-(RPl+RATIOP*(X-Sl)*(l-IFHEAV(Sl,X)))*IFHEAV(S2,X) 

+  +RP2*(1-IFHEAV(S2,X))*IFHEAV(S3.X) 

RETURN 

END 

********-k-k***********-k*******ie**********iic******* 

FUNCTION  BLTRAD(X) 

FINDS  RADIUS  OF  BOLT  AT  ANY  POSITION  X  AT  A  GIVEN  TIME 
WHICH  FIXES  S1,S2,S3  RELATIVE  TO  BOLT 

COMMON  /FI6/  RHOL,RKl,RK2,VOLFO,PSI,AV 

COMMON  /F19/  RPl,RP2,RP3,RBl,RB2,RB3,VOL12,VOL23 

COMMON  /F21/  RLBLTF,RLBLTS,NPRPTS,ORIGS3,ORIGS2,ORIGSl,X3.X2,Xl.IP 

COMMON  /F23/  IPRES .RADDF, RADDB, RATIOP.RATIOB 

COMMON  /F24/  S3,S2,S1,RINTAR,RINTP3 

BLTRAD- (RBl+RAI lOB* (X- XI ) * ( 1 - IFHEAV (XI , X) ) ) *IFHEAV (X2 , X) 

+  +RB2*(1-IFHEAV(X2,X))*IFHEAV(X3,X) 

RETURN 

END 

-kir-ifk-k'icie-k-kic-k-k**********************-*!************* 

FUNCTION  FAREA(X) 

CALLED  TO  EVALUATE  A(X,T) 

COMMON  /FI 6/  RHOL,RKl,RK2, VOLFO.PS I, AV 

COMMON  /F19/  RPl,RP2,RP3,RBl,RB2,RB3,VOL12.VOL23 

COMMON  /F21/  RLBLTF,RLBLTS,NPRPTS.ORIGS3,ORIGS2,ORIGSl,X3,X2,Xl.IP 

COMMON  /F23/  IPRES , RADDP, RADDB, RATIOP.RATIOB 

COMMON  /F24/  S3 , S2 , SI ,RINTAR,RINTP3 
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C 


PARAMETER  (PI-3.141592654) 


TERMS  USED  TO  FIND  AREA  A(X,T) 

TRMRP1-RP1*RP1*I FHEAV ( S2 , X) 

+  +RP2*RP2*(1-IFHEAV(S2,X))*IFHEAV(S3,X) 

TRMRP2-RP1*RATI0P* ( 1 - IFHEAV(S 1 , X) ) *IFHEAV ( S2 , X) 
TRMRP3-RATI0P*RATI0P* ( 1 - IFHEAV ( SI . X) ) *IFHEAV ( S2 , X) 

TRMRP4-TRMRP1 -  2 . *TRMR?2*S1+TRMRP3*S1*S1 
TRMRP5-TRMRP2 - TRMRP3*S 1 
TRMRB1-RB1*RB1*IFHEAV(X2 .X) 

+  +RB2*RB2* ( 1 - IFHEAV (X2 , X) ) *IFHEAV (X3 , X) 

TRMRB2-RB1*RATI0B*(1-IFHEAV(X1 ,X) )*IFHEAV(X2 ,X) 
TRMRB3-RATI0B*RATI0B* ( 1 - IFHEAV(X1 , X) )*IFHEAV(X2 , X) 

TRMRB4-TRMRB1 -  2 . *TRMRB2*X1+TRMRB3*X1*X1 
TRMRB5-TRMRB2 - TRMRB3*X1 

TERMS  IN  AREA  OF  LIQUID  EXPRESSED  AS  A  TRINOMIAL 
TRMAL1-TRMRP4 - TRMRB4 
TRMAL2-TRMRP5 - TRMRB5 
TRMAL3-TRMRP3 - TRMRB3 

AREA  OF  LIQUID  BETWEEN  PISTON  AND  BOLT 
FAREA-PI*(TRMALl+2 . *TRMAL2*X+TRMAL3*X*X) 

RETURN 

END 

************************************************ 

FUNCTION  FVOL(X) 

FINDS  VOLUME  OF  LIQUID  AT  ANY  POSITION  X  AT  A  GIVEN  TIME 
WHICH  FIXES  S1,S2,S3  RELATIVE  TO  BOLT 

COMMON  /FI6/  RHOL,RKl,RK2,VOLFO,PSI,AV 

COMMON  /F19/  RPl,RP2,RP3,RBI,RB2.RB3,VOL12,VOL23 

COMMON  /F21/  RLBLTF,RLBLTS,NPRPTS,ORIGS3,ORIGS2,ORIGSl,X3,X2,Xl,IP 
COMMON  /F23/  IPRES ,RADDP,RADDB,RATIOP,RATIOB 
COMMON  /F24/  S3 , S2 , SI ,RINTAR,RINTP3 
COMMON  /F25/  I 

PARAMETER  (PI-3.141592654) 

AREA  OF  BACK  WALL 
AW-PI* (RP1*RP1 -RB1*RB1 ) 

VOLUME  DEPENDS  ON  X  RELATIVE  TO  S1,S2,S3  AND  X1,X2,X3 
IF  (X.LE.Sl)  VOLLIQ-AW*X 

WITH  OFFSET  >-.2788  SLANT  OF  PIST  IS  NEVER  OVER  SLANT  OF  BOLT 
IF  ((X.GT.Sl) .AND. (X.LE.S2))  THEN 
B1-PI*RP1*RP1 
B2-PI*PISRAD(X)*PISRAD(X) 

VOLLIQ-AW*S 1+ ( 1 . /3 . ) * (X- S 1 ) * ( B1+B2+SQRT ( B1*B2 ) ) 

+  -PI*RB1*RB1*(X-S1) 

ENDIF 
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IF  (((X.GT.S2).AND.(X.LE.S3)).AND.(X.LE.X1))  THEN 
B1-PI*RP1*RP1 

B2-PI*PISRAD(S2)*PISRAD(S2) 

VOLLIQ-AW*S 1+(1./3)*(S2-S1)* ( B1+B2+SQRT ( B1*B2 ) ) 

+  -PI*RB1*RB1*(S2-S1) 

+  +PI*(RP2*RP2-RB1*RB1)*(X-S2) 

ENDIF 

C 

IF  (((X.GT.S2).AND.(X.LE.S3)).AND.((X.GT.X1).AND.(X.LE.X2)))  THEN 
B1-PI*RP1*RP1 

B2-PI*PISRAD(S2)*PISRAD(S2) 

B3-PI*RB1*RB1 
B4-PI*BLTRAD (X) *BLTRAD (X) 

VOLLIQ-AW*S 1+(1./3.)*(S2-S1)*(B1+B2+SQRT(B1*B2)) 

+  -PI*RB1*RB1*(S2-S1)+PI*RP2*RP2*(X-S2) 

+  -(1./3.)*(X-S2)*(B3+B4+SQRT(B3*B4)) 

ENDIF 

C 

IF  (((X.GT.S2) .AND. (X.LE.S3)) .AND. ((X.GT.X2).AND. (X.LE.X3))) 

+  V0LLIQ-AW*S1+(1 ./3 . )*(S2-S1)*(B1+B2+SQRT(B1*B2) ) 

+  -PI*RB1*RB1*(S2-S1)+PI*RP2*RP2*(X2-S2) 

+  -(l./3.)*(X2-S2)*(B3+B4+SQRT(B3*B4)) 

+  +(X-X2)*PI*(RP2*RP2-RB2*RB2) 

FVOL-VOLLIQ 

RETURN 

END 

Q  *★*****************'**********★**★****★★♦*★**★**★ 

FUNCTION  FIA(X) 

C 

C  CALLED  TO  EVALUATE  l./A(X,T) 

FlA-l./FAREA(X) 

RETURN 

END 

C  ************************************************ 

FUNCTION  FVA(X) 

C 

C  CALLED  TO  EVALUATE  V(X,T)/A(X,T) 

FVA-FVOL (X) /FAREA (X) 

RETURN 

END 

C  ************************************************ 

FUNCTION  FXA(X) 

C 

C  CALLED  TO  EVALUATE  X*A(X,T) 

FXA-X*FAREA(X) 

RETURN 

END 

C  ************************************************ 

FUNCTION  FV2A(X) 

C 

C  CALLED  TO  EVALUATE  V(X,T)*V(X.T)/A(X,T) 

VOl^FVOL(X) 

FV2A-VOL*VOL/FAREA (X) 

RETURN 

END 
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C  ************************************************ 

FUNCTION  FVA2(X) 

CALLED  TO  EVALUATE  V(X,T)/(A(X,T)*A(X,T) ] 

AREA-FARFJV(X) 

FVA2-FV0L(X) / ( AREA*AREA) 

RETURN 
END 

************************************************ 

FUNCTION  FAIIA(X) 

CALLED  TO  EVALUATE  A(X,T)*INTEGRAL  l./A(X,T) 

FROM  SI  TO  X 

COMMON  /F24/  S3 , S2 , SI ,RINTAR,RINTP3 
EXTERNAL  FlA 
AREA-FAREA(X) 

CALL  QR0M02(F1A,S1,X,RIN1A) 

FAI1A-AREA*RIN1A 
RETURN 
END 

************************************************ 

FUNCTION  FAIVA(X) 

CALLED  TO  EVALUATE  A(X,T)*INTEGRAL  V(X,T)/A(X,T) 

FROM  SI  TO  X 

COMMON  /F24/  S3 , S2 , SI ,R1NTAR,RINTP3 
EXTERNAL  FVA 
ARLA-FAREA(X) 

CALL  QR0M02(FVA,S1,X,RINVA) 

FAI7A-AREA*RINVA 
RETURN 
END 

************************************************ 

FUNCTION  FAIVA2(X) 

CALLED  TO  EVALUATE  A(X,T)*INTEGRAL  V(X,T)/[A(X,T)*A(X,T) ] 

FROM  SI  TO  X 

COMMON  /F24/  S3 , S2 . SI ,RINTAR,RINTP3 
EXTERNAL  FVA2 
AREA-FAREA(X) 

CALL  QR0M02(FVA2,S1.X,RINVA2) 

FAIVA2-AREA*RINVA2 
RETURN 
END 

C  ************************************************ 

C  — - - >  BEGIN  INTEGRATOR 

C  ADAPTED  FROM  NUMERICAL  RECIPES  BY  W.  PRESS  ET  AL 
C  ******************************************* 

SUBROUTINE  QROMO(FUNC,A,B,SS) 

C  ROMBERG  INTEGRATION 

PARAMETER  (EPS-1.E-5,JMAX-14,JMAXP-JMAX+1 ,K-5,KM-K-1) 
DIMENSION  S(JMAXP) ,H(JMAXP) 

EXTERNAL  FUNC 

DO  11  J-1,JMAX 
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CALL  MIDPNT(FUNC,A,B,S(J) .J) 

IF  (J.GE.K)  THEN 

CALL  POLINT(H(J-KM) ,S(J-KM) ,K.O.O,SS,DSS) 
IF  (ABS(DSS) .LT.EPS*ABS(SS))  RETURN 
ENDIF 

S(J+1)-S(J) 

H(J+l)-H(J)/9. 

11  CONTINUE 

WRITE(*,50) 

50  F0RMAT(1X,'  INTEGRATION  CANNOT  CONVERGE') 

RETURN 

END 

C  ******************************************** 

SUBROUTINE  MIDPNT(FUNC,A,B,S,N) 

EXTERNAL  FUNC 
IF  (N.EQ.l)  THEN 
Y-0.5*(A+B) 

S-(B-A)*FUNC(Y) 

IT-1 

ELSE 

TNM-IT 

DEL-(B-A)/(3.*TNM) 

DDEL-DEL+DEL 
X-A+O . 5*DEL 
SUM-O. 

DO  11  J-1,IT 
SUM-SUM+FUNC(X) 

X-X+DDEL 

SUM-SUM+FUNC(X) 

X-X+DEL 

11  CONTINUE 

S-(S+(B-A)*SUM/TNM)/3 . 

IT-3*IT 

ENDIF 

RETURN 

END 

C 

C  ******************************************* 
SUBROUTINE  POLINT(XA, YA.N.X, Y,DY) 

PARAMETER  (NMAX-10) 

DIMENSION  XA(N),YA(N),C(NMAX),D(NMAX) 

NS-1 

DIF-ABS(X-XA(1)) 

DO  11  I-1,N 

DIFT-ABS(X-XA(1)) 

IF  (DIFT.LT.DIF)  THEN 
NS-I 

DIF-DIFT 

ENDIF 

C(I)-YA(I) 

D(I)-YA(I) 

11  CONTINUE 
Y-YA(NS) 
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NS-NS-1 
DO  13 

DO  12  I-1,N-M 
HO-XA(I)-X 
HP-XA(I+M)-X 
W-C(I+1)-D(I) 

DEN-HO-HP 
IF(DEN.EQ.O. ) PAUSE 
DEN-W/DEN 
D(I)-HP*DEN 
C(I)-HO*DEN 

12  CONTINUE 

IF  (2*NS.LT.N-M)THEN 
DY-C(NS+1) 

ELSE 

DY-D(NS) 

NS-NS-1 

ENDIF 

Y-Y+DY 

13  CONTINUE 
RETURN 

END 

C  ********************************************* 

C  END  INTEGRATOR  1  <— — — — — — 

c  - -  — >  begin  integrator  2 

C  **********************************-.'.  ******** 

SUBROUTINE  QR0M02(FUNC,A,B.SS) 

C  ROMBERG  INTEGRATION 

PARAMETER  (EPS-1 . E- 5 , JMAX-14 , JMAXP-JMAX+1 , K-5 , KM-K- 1 ) 
DIMENSION  S(JMAXP),H(JMAXP) 

EXTERNAL  FUNC 

H(l)-1. 

DO  11  J-1,JMAX 

CALL  MIDPT2(FUNC,A,B,S(J),J) 

IF  (J.GE.K)  THEN 

CALL  POLIN2(H(J-KM) ,S(J-KM) ,K,0.0,SS,DSS) 

IF  (ABS(DSS) .LT.EPS*ABS(SS))  RETURN 
ENDIF 

S(J+1)-S(J) 

H(J+l)-H(J)/9. 

11  CONTINUE 

WRITE(*,50) 

50  FORMAT (IX,'  INTEGRATION  CANNOT  CONVERGE') 

RETURN 

END 

C  ******************************************* 

SUBROUTINE  MIDPT2(FUNC,A,B,S,N) 

EXTERNAL  FUNC 
IF  (N.EQ.l)  THEN 
Y-0.5*(A+B) 

S-(B-A)*FUNC(Y) 

IT-1 
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TNM-IT 

DEL-(B-A)/(3.*TNM) 

DDEL-DEL+DEL 
X-A+0 . 5*DEL 
SUM-0. 

DO  11  J-1,IT 
SUM-SUM+FUNC(X) 

X-X+DDEL 

SUM-SUM+FUNC(X) 

X-=*X+DEL 

11  CONTINUE 

S-(S+(B-A)*SUM/TNM)/3 . 

IT-3*IT 

ENDIF 

RETURN 

END 

*********T<-)r**********  ********************** 

SUBROUTINE  POLIN2(XA,YA,N,X,Y,DY) 

PARAMETER  (NMAX-10) 

DIMENSION  XA(N) ,YA(N) ,C(NMAX) ,D(NMAX) 

NS-1 

DIF-ABS(X-XA(1)) 

DO  11  I-1,N 

DIFT-ABS(X-XA(I)) 

IF  (DIFT.LT.DIF)  THEN 
NS-I 

DIF-DIFT 

ENDIF 

C(I)-YA(I) 

D(I)-YA(I) 

11  CONTINUE 
Y-YA(NS) 

NS-NS-1 

DO  13  M-l.N-1 
DO  12  I-1,N-M 
HO-XA(I)-X 
HP-XA(I+M)-X 
W-C(I+1)-D(I) 

DEN-HO-HP 
IF(DEN.EQ.O.) PAUSE 
DEN-W/DEN 
D(I)-HP*DEN 
C(I)-HO*DEN 

12  CONTINUE 

IF  (2*NS.LT.N-M)THEN 
DY-C(NS+1) 

ELSE 

DY-D(NS) 

NS-NS-1 

ENDIF 

Y-Y+DY 

13  CONTINUE 
RETURN 

END 


c  ******************************************* 

C  END  INTEGRATOR  2  — — — — 

C  ******************************************* 

C  ODE  SOLVER- -RECEIVED  FROM  D.  KAHANER 

C  NATIONAL  BUREAU  OF  STANDARDS 

C  ******************************+************ 

SUBROUTINE  FDUMP 
C***BEGIN  PROLOGUE  FDUMP 
C***DATE  WRITTEN  790801  (YYMMDD) 

C***REVISION  DATE  820801  (YYMMDD) 

C***CATEGORY  NO .  Z 
C***KEYWORDS  ERROR, XERROR  PACKAGE 
C***AUTH0R  JONES,  R.  E.,  (SNLA) 

C***PURPOSE  Symbolic  dump  (should  be  locally  written) . 

c***description 

C  Written  by  Ron  Jones,  with  SLATEC  Common  Math  Library  Subcommittee 
C  Latest  revision  ---  23  May  1979 

C***ROUTINES  CALLED  (NONE) 

C***END  PROLOGUE  FDUMP 
C***FIRST  EXECUTABLE  STATEMENT  FDUMP 
RETURN 
END 

INTEGER  FUNCTION  IIMACH(I) 

C 

C  THIS  SHORT  FUNCTION  REPLACES  THE  ORIGINAL  FUNCTION  IIMACH(I)  BY 
C  FOX,  HALL  AND  SCHRYER  OF  BELL  LABS. 

C  I-LOK  CHANG  JANUARY  6,  1985  IBM  PC  Family 

C 

C  imach(l)  is  standard  unit  for  input 

C  imach(2)  is  standard  unit  for  output 

C  imach(4)  is  standard  unit  for  error  messages 

C  imach(6)  is  number  of  characters  per  storage  unit 

C  imach(9)  is  largest  integer 

C  imach(lO)  is  base  for  floating  point  numbers 
C  imach(ll)  is  number  of  digits  in  single  precision  mantissa 
C 

INTEGER  IMACH(16) 

DATA  IMACH/0, 6, 0,4, 0,1, 0.0, 2147483647, 2, 23, 5*0/ 

IF  (  (I  .EQ.  4)  .OR.  (I  .EQ.  6)  .OR.  (I.EQ.2) 

*  .OR.  (I.EQ.9)  .OR.  (I.EQ.ll)  .OR.  (I.EQ.IO))  GO  TO  1 

WRITE(*,5)  I 

5  FORMAT('  REQUESTED  MACHINE  CONSTANT  I1MACH( ' , 12 , '  )IS  NOT 

8AVILABLE.  STOP  IN  FUNCTION  IIMACH(I)') 

STOP 

1  CONTINUE 

IlMACH  -  IMACH(I) 

RETURN 

END 

INTEGER  FUNCTION  ISAMAX(N, SX, INCX) 

C 

C  FIND  SMALLEST  INDEX  OF  MAXIMUM  MAGNITUDE  OF  SINGLE  PRECISION  SX. 

C  ISAMAX  -  FIRST  I,  I  -  1  TO  N,  TO  MINIMIZE  ABS(SX(1-INCX+I*INCX) ) 

C 

REAL  SX(1) ,SMAX,XMAG 
ISAMAX  -  0 
IF(N.LE.O)  RETURN 
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ISAMAX  -  1 
IF(N.LE.1)RETURN 
IF(INCX.EQ.1)G0T0  20 
C 

C  CODE  FOR  INCREMENTS  NOT  EQUAL  TO  1. 

C 

SMAX  -  ABS(SX(1)) 

NS  -  N*INCX 
II  -  1 

DO  10  I-1,NS.INCX 
XMAG  -  ABS(SX(I)) 

IF(XMAG.LE.SMAX)  GO  TO  5 
ISAMAX  -  II 
SMAX  -  XMAG 
5  II  -  II  +  1 

10  CONTINUE 

RETURN 
C 

C  CODE  FOR  INCREMENTS  EQUAL  TO  1. 

C 

20  SMAX  -  ABS(SX(1)) 

DO  30  I  -  2, N 

XMAG  -  ABS(SX(I)) 

IF (XMAG. LE. SMAX)  GO  TO  30 
ISAMAX  -  I 
SMAX  -  XMAG 
30  CONTINUE 
RETURN 
END 

FUNCTION  J4SAVE(IWHICH,IVALUE,ISET) 

C***BEGIN  PROLOGUE  J4SAVE 
C***REFER  TO  XERROR 
C  Abstract 

C  J4SAVE  saves  and  recalls  several  global  variables  needed 

C  by  the  library  error  handling  routines. 

C 

C  Written  by  Ron  Jones,  with  SLATEC  Common  Math  Library  Subcommittee 
C  Adapted  from  Bell  Laboratories  PORT  Library  Error  Handler 
C  Latest  revision  ---  23  MAY  1979 

C***REFERENCES  JONES  R.E.,  KAHANER  D.K. ,  "XERROR,  THE  SLATEC  ERROR - 
C  HANDLING  PACKAGE",  SAND82-0800,  SANDIA  LABORATORIES, 

C  1982. 

C***ROUTINES  CALLED  (NONE) 

C***END  PROLOGUE  J4SAVE 
LOGICAL  ISET 
INTEGER  IPARAM(9) 

SAVE  IPARAM 

DATA  IPARAM(l) ,IPARAM(2) ,IPARAM(3),IPARAM(4)/0,2,0,10/ 

DATA  IPARAM(5)/1/ 

DATA  IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0, 0,0,0/ 

C***FIRST  EXECUTABLE  STATEMENT  J4SAVE 
J4SAVE  -  IPARAM(IWHICH) 

IF  (ISET)  IPAPJVM(IWHICH)  -  IVALUE 

RETURN 

END 

FUNCTION  NUMXER(NERR) 
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C***BEGIN  PROLOGUE  NUMXER 
C***REFER  TO  XERROR 
C  Abstract 

C  NUMXER  returns  the  most  recent  error  number, 

C  in  both  NUMXER  and  the  parameter  NERR. 

C 

C  Written  by  Ron  Jones,  with  SLATEC  Common  Math  Library  Subcommittee 
C  Latest  revision  —  7  JUNE  1978 

C***REFERENCES  JONES  R.E..  KAHANER  D.K. ,  "XERROR,  THE  SLATEC  ERROR- 
C  HANDLING  PACKAGE",  SAND82-0800,  SANDIA  LABORATORIES, 

C  1982. 

C***ROUTINES  CALLED  J4SAVE 
C***END  PROLOGUE  NUMXER 
C***FIRST  EXECUTABLE  STATEMENT  NUMXER 
NERR  -  J4SAVE( 1,0, .FALSE.) 

NUMXER  -  NERR 
RETURN 
END 
C 

REAL  FUNCTION  RIMACH(I) 

C  this  short  routine  replaces  the  original  function  rlmach 
C  by  fox,  hall  and  schryer. 

C 

C  i-lok  chang  September  17,  1984  For  IBM  PC  family  ***** 

C 

C  Changes:  (DKK) 

C  28  March  1986: 

C  Altered  rmach(l)  from  1.40128e-44  to  1.4e-38 

REAL  RMACH(5) 

INTEGER  I 

IF  (  (I  .NE.  1)  .AND.  (I  .NE.  4)  .AND.  (I.NE.2))  GO  TO  1 
RMACH(l)  -  1.4E-38 
RMACH(2)  -  3.0E+38 
RMACH(4)  -  1.192093E-6 
RIMACH  -  RMACH(I) 

GO  TO  5 
1  CONTINUE 

WRITE(*,10)  I 

10  FORMAT('  REQUEST  INDEX  TO  RIMACH  IS',  13,'  PROGRAM  STOPS  AT 
o  tuiioTIGN  RlHACh'  ) 

STOP 

5  CONTINUE 

RETURN 
END 

SUBROUTINE  SAXPY(N , SA , SX , INCX , SY, INCY) 

C 

C  OVERWRITE  SINGLE  PRECISION  SY  WITH  SINGLE  PRECISION  SA*SX  +SY. 

C  FOR  I  -  0  TO  N-1,  REPLACE  SY(LY+I*INCY)  WITH  SA*SX(LX+I*INCX)  + 

C  Sy(LY+I*INCY) ,  WHERE  LX  -  1  IF  INCX  .GE.  0,  ELSE  LX  -  (-INCX)*N, 

C  AND  LY  IS  DEFINED  IN  A  SIMILAR  WAY  USING  INCY. 

C 

REAL  SX(1) ,SY(1) ,SA 
IF(N.LE.O.OR.SA.EQ.O.EO)  RETURN 
IF(INCX.EQ.INCY)  IF(INCX-l)  5,20,60 
5  CONTINUE 
C 
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C  CODE  FOR  NONSQUAL  OR  NONPOSITIVE  INCREMENTS. 

C 

IX  -  1 
lY  -  1 

lF(INCX.LT.O)iX  -  (-N+1)*INCX  +  1 
IF(INCY.LT.O)IY  -  (-N+1)*INCY  +  1 
DO  10  I  -  1,N 

SY(IY)  -  SY(IY)  +  SA*SX(IX) 

IX  -  IX  +  INCX 

lY  -  lY  +  INCY 

10  CONTINUE 
RETURN 
C 

C  CODE  FOR  BOTH  INCREMENTS  EQUAL  TO  1 

C  CLEAN-UP  LOOP  SO  REMAINING  VECTOR  LENGTH  IS  A  MULTIPLE  OF  4. 

C 

20  M  -  M0D(N,4) 

IF(  M  .EQ.  0  )  GO  TO  40 
DO  30  I  -  1,M 

SY(I)  -  SY(I)  +  SA*SX<I) 

30  CONTINUE 

IF(  N  .LT.  4  )  RETURN 
40  MPl  -  M  +  1 

DO  50  I  -  MP1,N,4 

SY(I)  -  SY<I)  +  SA*SX(I) 

SY(I  +  1)  -  SY(I  +  1)  +  SA*SX(I  +  1) 

SY(I  +  2)  -  SY(I  +  2)  +  SA*SX(I  +  2) 

SY(I  +  3)  -  SY(I  +  3)  +  SA*SX(I  i  3) 

50  CONTINUE 
RETURN 
C 

C  CODE  FOR  EQUAL,  POSITIVE,  NONUNIT  INCREMENTS. 

C 

60  CONTINUE 
NS  -  N*INCX 

DO  70  I-1,NS,INCX 
SY(I)  -  SA*SX(I)  +  SY<I) 

70  CONTINUE 
RETURN 
END 

SUBROUTINE  SDCOR  (DFDY,EL,FA,H,IMPL, IPVT,MATDIM,MITER,ML,MU,N, 

8  NDE , NQ , T . USERS , Y , YH , YWT . EVALFA , SAVEl . SAVE2 , A , D , JSTATE) 
C***BEGIN  PROLOGUE  SDCOR 
C***REFER  TO  SDRIV3 

C  Subroutine  SDCOR  is  called  to  compute  corrections  to  the  Y  array . 

C  In  the  case  of  functional  iteration,  update  Y  directly  from  the 
C  result  of  the  last  call  to  F. 

C  In  the  case  of  the  chord  method,  compute  the  corrector  error  and 
C  solve  the  linear  system  with  that  as  right  hand  side  and  DFDY  as 
C  coefficient  matrix,  using  the  LU  decomposition  if  MITER  is  1,  2,  4 
C  or  5 . 

C***ROUTINES  CALLED  SGESL, SGBSL, SNRM2 
C***DATE  WRITTEN  790601  (YYMMDD) 

C***REVISION  DATE  870401  (YYMMDD) 

C***CATEGORY  NO.  I1A2,I1A1B 

C***AUTH0R  KAHANER,  D.  K. ,  NATIONAL  BUREAU  OF  STANDARDS, 
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C  SUTHERLAND ,  C .  D . ,  LOS  ALAMOS  NATIONAL  LABORATORY 

C***END  PROLOGUE  SDCOR 

REAL  A(MATDIM,*) ,  D.  DFDY(MATDIM. *) ,  EL(13,12),  H, 

8  SAVE1(*),  SAVE2(*).  SNRM2.  T.  Y(*) ,  YH(N,*),  YWT(*) 

INTEGER  IPVT(*) 

LOGICAL  EVALFA 

C***FIR-..  EXECUTABLE  STATEMENT  SDCOR 
^F  (MITER  .EQ.  0)  THEN 
DO  100  I  -  l.N 

100  SAVEl(I)  -  (H*SAVE2(I)  -  YH(I,2)  -  SAVE1(I))/YWT(I) 

D  -  SNRM2(N,  SAVEl,  1)/SQRT(REAL(N) ) 

DO  105  I  -  1,N 

105  SAVEl(I)  -  H*SAVE2(I)  -  YH(I,2) 

ELSE  IF  (MITER  .EQ.  1  .OR.  MITER  .EQ.  2)  THEN 
IF  (IMPL  .EQ.  0)  THEN 
DO  130  I  -  l.N 

130  SAVE2(I)  -  H*SAVE2(I)  -  YH(I,2)  -  SAVEl(I) 

ELSE  IF  (IMPL  .EQ.  1)  THEN 
IF  (EVALFA)  THEN 

CALL  FA  (N,  T,  Y,  A,  MATDIM,  ML,  MU,  NDE) 

IF  (N  .EQ.  0)  THEN 
JSTATE  -  9 
RETURN 
END  IF 
ELSE 

EVALFA  -  .TRUE. 

END  IF 

DO  150  I  -  l.N 

150  SAVE2(I)  -  H*SAVE2(I) 

DO  160  J  -  l.N 
DO  160  I  -  l.N 

160  SAVE2(1)  -  SAVE2(1)  -  A(I , J)*(YH(J , 2)  +  SAVEl(J)) 

ELSE  IF  (IMPL  .EQ.  2)  THEN 
IF  (EVALFA)  THEN 

CALL  FA  (N,  T,  Y,  A,  MATDIM,  ML,  MU,  NDE) 

IF  (N  .EQ.  0)  THEN 
JSTATE  -  9 
RETURN 
END  IF 
ELSE 

EVALFA  -  .TRUE. 

END  IF 

DO  180  I  -  l.N 

180  SAVE2(I)  -  H*SAVE2(I)  -  A(1 . 1)*(YH(1 , 2)  +  SAVEl(I)) 

END  IF 

CALL  SGESL  (DFDY,  MATDIM,  N,  IPVT,  SAVE2 ,  0) 

DO  200  I  -  l.N 

SAVEl(I)  -  SAVEl(I)  +  SAVE2(I) 

200  SAVE2(I)  -  SAVE2(I)/YWT(I) 

D  -  SNRM2(N,  SAVE2,  1)/SQRT(REAL(N) ) 

ELSE  IF  (MITER  .EQ.  4  .OR.  MITER  .EQ.  5)  THEN 
IF  (IMPL  .EQ.  0)  THEN 
DO  230  I  -  l.N 

230  SAVE2(I)  -  H*SAVE2(I)  -  YH(I,2)  -  SAVEl(I) 

ELSE  IF  (IMPL  .EQ.  1)  THEN 
IF  (EVALFA)  THEN 
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CALL  FA  (N,  T,  Y.  A(ML+1,1),  MATDIM,  ML,  MU,  NDE) 

IF  (N  .EQ.  0)  THEN 
J STATE  -  9 
RETURN 
END  IF 
ELSE 

EVALFA  -  .TRUE. 

END  IF 

DO  250  I  -  1,N 

250  SAVE2(I)  -  H*SAVE2(I) 

MW  -  ML  +  1  +  MU 
DO  260  J  -  I,N 

11  -  MAX(ML+1,  MW+l-J) 

12  -  MIN(MW+N-J,  MW+ML) 

DO  260  I  -  11,12 

13  -  I  +  J  -  MW 

260  SAVE2(I3)  -  SAVE2(I3)  -  A(I , J)*(YH(J . 2)  +  SAVEl(J)) 

ELSE  IF  (IMPL  .EQ.  2)  THEN 
IF  (EVALFA)  THEN 

CALL  FA  (N,  T,  Y,  A,  MATDIM,  ML,  MU,  NDE) 

IF  (N  .EQ.  0)  THEN 
JSTATE  -  9 
RETURN 
END  IF 
ELSE 

EVALFA  -  .TRUE. 

END  IF 

DO  280  I  -  1,N 

280  SAVE2(I)  -  H*SAVE2(I)  -  A(I , 1)*(YH(I , 2)  +  SAVEl(I)) 

END  IF 

CALL  SGBSL  (DFDY,  MATDIM,  N,  ML,  MU,  IPVT,  SAVE2 ,  0) 

DO  300  I  -  1,N 

SAVEl(I)  -  SAVEl(I)  +  SAVE2(1) 

300  SAVE2(I)  -  SAVE2(I)/YWT(I) 

D  -  SNRM2(N,  SAVE2,  1)/SQRT(REAL(N) ) 

ELSE  IF  (MITER  .EQ.  3)  THEN 
IFLAG  -  2 

CALL  USERS  (Y,  YH(1,2),  YWT,  SAVEl,  SAVE2 ,  T,  H,  EL(1,NQ),  IMPL. 
8  N,  NDE,  IFLAG) 

IF  (N  .EQ.  0)  THEN 
JSTATE  -  10 
RETURN 
END  IF 

DO  320  I  -  1,N 

SAVEl(I)  -  SAVEl (I)  +  SAVE2(I) 

320  SAVE2(I)  -  SAVE2(I)/YWT(I) 

D  -  SNRM2(N,  SAVE2,  1)/SQRT(REAL(N) ) 

END  IF 
END 

SUBROUTINE  SDCST  (MAXORD,MINT,ISWFLG,EL.TQ) 

C***BEGIN  PROLOGUE  SDCST 
C***REFER  TO  SDRIV3 

C  SDCST  is  called  by  SDNTL  and  sets  coefficients  used  by  the  core 
C  Integrator  SDSTP.  The  array  EL  determines  the  basic  method. 

C  The  array  TQ  is  Involved  in  adjusting  the  step  size  in  relation 
C  to  truncation  error.  EL  and  TQ  depend  upon  MINT,  and  are  calculated 
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C  for  orders  1  to  MAXORD(.LE.  12).  For  each  order  NQ,  the  coefficients 
C  EL  are  calculated  from  the  generating  polynomial; 

C  L(T)  -  EL(1,NQ)  +  EL(2.NQ)*T  +  ...  +  EL(NQ+1 .NQ)*T**NQ. 

C  For  the  implicit  Adams  methods,  L(T)  is  given  by 
C  dL/dT  -  (1+T)*(2+T)*  ...  *(NQ-1+T)/K,  L(-l)  -  0, 

C  where  K  -  factorial (,NQ- 1) . 

C  For  the  Gear  methods, 

C  L(T)  -  (1+T)*(2+T)*  ...  *(NQ+T)/K, 

C  where  K  -  factorial(NQ)*(l  +  1/2  +  ...  +  1/NQ) . 

C  For  each  order  NQ,  there  are  three  components  of  TQ. 

C***R0UTINES  CALLED  (NONE) 

C***DATE  WRITTEN  790601  (YYMMDD) 

C***REVISI0N  DATE  870216  (YYMMDD) 

C***CATEGORY  NO.  I1A2,I1A1B 

C***AUTH0R  KAHANER,  D.  K.  ,  NATIONAL  B’JREAU  OF  STANDARDS, 

C  SUTHERLAND,  C.  D. ,  LOS  AL7MOS  NATIONAL  LABORATORY 

c***end  prologue  SDCST 

REAL  EL(13,12) ,  FACTRL(12),  GAMMA(14) ,  SUM,  TQ(3,12) 

C***FIRST  EXECUTABLE  STATEMENT  SDCST 
FACTRL(l)  -  l.EO 
DO  10  I  -  2,MAX0RD 

10  FACTRL(I)  -  REAL(I)*FACTRL(I-1) 

C  COMPUTE  ADAMS  COEFFICIENTS 

IF  (MINT  .EQ.  1)  THEN 
GAMMA(l)  -  l.EO 
DO  40  I  -  1,MAX0RD+1 
SUM  -  O.EO 
DO  30  J  -  1,1 

30  SUM  -  SUM  -  GAMMA(J)/REAL(I-J+2) 

40  GAMMA(I+1)  -  SUM 

EL(1,1)  -  l.EO 
EL(2,1)  -  l.EO 
EL(2,2)  -  l.EO 
EL(3,2)  -  l.EO 
DO  60  J  -  3,MAXORD 

EL(2,J)  -  FACTRL(J-l) 

DO  50  I  -  3, J 

50  EL(I,J)  -  REAL(J-1)*EL(I,J-1)  +  EL(I-1,J-1) 

60  EL(J+1,J)  -  l.EO 

DO  80  J  -  2,MAXORD 

EL(1,J)  -  EL(1,J-1)  +  GAMMA(J) 

EL(2,J)  -  l.EO 

DO  80  I  -  3,J+1 

80  EL(I,J)  -  EL(I,J)/(REAL(I-1)*FACTRL(J-1)) 

DO  100  J  -  l,MAXORD 

TQ(1,J)  -  -1.E0/(FACTRL(J)*GAMMA(J)) 

TQ(2,J)  -  -1.E0/GAMMA(J+1) 

100  TQ(3,J)  -  -l.E0/GAMMA(J+2) 

C  COMPUTE  GEAR  COEFFICIENTS 

ELSE  IF  (MINT  .EQ.  2)  THEN 
EL(1,1)  -  l.EO 
EL(2,1)  -  l.EO 
DO  130  J  -  2,MAXORD 
EL(1,J)  -  FACTRL(J) 

DO  120  I  -  2,J 

120  EL(I,J)  -  REAL(J)*Lu(I,J-l)  +  EL(I-1,J-1) 
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EL(J+1,J)  -  l.EO 
SUM  -  l.EO 
DO  150  J  -  2,MAX0RD 

SUM  -  SUM  +  l.EO/REAL(J) 

DO  150  I  -  1,J+1 
150  EL(I,J)  -  EL(I,J)/(FACTRL(J)*SUM) 

DO  170  J  -  l.MAXORD 

IF  (J  .GT.  1)  TQd.J)  -  l.EO/FACTRL(J-l) 

TQ(2,J)  -  REAL(J+1)/EL(1,J) 

170  TQ(3,J)  -  REAL(J+2)/EL(l,J) 

END  IF 

Compute  constants  used  in  the  stiffness  test. 
These  are  the  ratio  of  TQ(2,NQ)  for  the  Gear 
methods  to  those  for  the  Adams  methods. 

IF  (ISWFLG  .EQ.  3)  THEN 
MXRD  -  MIN(MAXORD,  5) 

IF  (MINT  .EQ.  2)  THEN 
GAMMA(l)  -  l.EO 
DO  190  I  -  l.MXRD 
SUM  -  O.EO 
DO  180  J  -  1,1 
180  SUM  -  SUM  -  GAMMA(J)/REAL(l-J+2) 

190  GAMMA(I+1)  -  SUM 

END  IF 
SUM  -  l.EO 
DO  200  I  -  2, MXRD 

SUM  -  SUM  +  l.E0/REAL(I) 

200  EL(1+I,1)  -  -REAL(I+1)*SUM*GAMMA(I+1) 

END  IF 
END 

SUBROUTINE  SDNTL  (EPS,F,FA.HMAX,HOLD,IMPL,JTASK,MATDIM,MAXORD, 

8  MINT, MITER, ML, MU, N,NDE,SAVE1,T,UR0UND, USERS, Y,WT,H,MNTOLD, 

8  MTROLD,NFE,RC,YH,A,CONVRG,EL,FAC,IER,IPVT,NQ,NWAIT,RH,RMAX, 

8  S AVE2, TQ, TREND, I SWFLG,J STATE) 

C***BEGIN  PROLOGUE  SDNTL 
C***REFER  TO  SDRIV3 

C  Subroutine  SDNTL  is  called  to  set  parameters  on  the  first  call 
C  to  SDSTP,  on  an  internal  restart,  or  when  the  user  has  altered 
C  MINT,  MITER,  and/or  H. 

C  On  the  first  call,  the  order  is  set  to  1  and  the  initial  derivatives 
C  are  calculated.  RMAX  is  the  maximum  ratio  by  which  H  can  be 
C  increased  in  one  step.  It  is  initially  RMINIT  to  compensate 
C  for  the  small  initial  H,  but  then  is  normally  equal  to  RMNORM. 

C  If  a  failure  occurs  (in  corrector  convergence  or  error  test),  RMAX 
C  is  set  at  RMFAIL  for  the  next  increase. 

C  If  the  caller  has  changed  MINT,  or  if  JTASK  -  0,  SDCST  is  called 
C  to  set  the  coefficients  of  the  method.  If  the  caller  has  changed  H, 

C  YH  must  be  rescaled.  If  H  or  MINT  has  been  changed,  NWAIT  is 

C  reset  to  NQ  +  2  to  prevent  further  increases  in  H  for  that  many 

C  steps.  Also,  RC  is  reset.  RC  is  the  ratio  of  new  to  old  values  of 

C  the  coefficient  L(0)*H.  If  the  caller  has  changed  MITER,  RC  is 
C  set  to  0  to  force  the  partials  to  be  updated,  if  partials  are  used. 
C***ROUTINES  CALLED  SDCST, SDSCL, SGEFA, SGESL, SGBFA, SGBSL, SNRM2 
C***DATE  WRITTEN  790601  (YYMMDD) 

C***REVISION  DATE  870810  (YYMMDD) 

C***CATEGORY  NO.  IlA2,IlAlB 
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C***AUTH0R  KAHANER,  D.  K. ,  NATIONAL  BUREAU  OF  STANDARDS, 

C  SUTHERLAND .  C .  D . .  LOS  ALAMOS  NATIONAL  LABORATORY 

C***END  PROLOGUE  SDNTL 

REAL  A(MATDIM,*) ,  EL(13,12),  EPS.  FAC(*),  H.  HMAX, 

8  HOLD,  OLDLO,  RC,  RH,  RMAX,  RMINIT,  SAVE1(*) ,  SAVE2(*) ,  SMAX, 

8  SMIN,  SNRM2,  SUM,  SUMO,  T,  TQ(3,12),  TREND,  UROUND,  Y(*) , 

8  YH(N,*),  YWT(*) 

INTEGER  IPVT(*) 

LOGICAL  CONVRG,  lER 
PARAMETER (RMINIT  -  10000. EO) 

C***FIRST  EXECUTABLE  STATEMENT  SDNTL 
lER  -  .FALSE. 

IF  (JTASK  .GE.  0)  THEN 
IF  (JTASK  .EQ.  0)  THEN 

CALL  SDCST  (MAXORD,  MINT,  ISWFLG,  EL,  TQ) 

RMAX  -  RMINIT 
END  IF 
RC  -  O.EO 
CONVRG  -  .FALSE. 

TREND  -  l.EO 
NQ  -  1 
NWAIT  “  3 

CALL  F  (N,  T,  Y,  SAVE2) 

IF  (N  .EQ.  0)  THEN 
JSTATE  -  6 
RETURN 
END  IF 

NFE  -  NFE  +  1 
IF  (IMPL  .NE.  0)  THEN 
IF  (MITER  .EQ.  3)  THEN 
IFLAG  -  0 

CALL  USERS  (Y,  YH,  YWT,  SAVEl,  SAVE2 ,  T,  H,  EL,  IMPL,  N, 

8  NDE,  IFLAG) 

IF  (N  .EQ.  0)  THEN 
JSTATE  -  10 
RETURN 
END  IF 

ELSE  IF  (IMPL  .EQ.  1)  THEN 

IF  (MITER  .EQ.  1  .OR.  MITER  .EQ.  2)  THEN 
CALL  FA  (N,  T,  Y.  A,  MATDIM,  ML,  MU,  NDE) 

IF  (N  .EQ.  0)  THEN 
JSTATE  -  9 
RETURN 
END  IF 

CALL  SGEFA  (A,  MATDIM,  N,  IPVT,  INFO) 

IF  (INFO  .NE.  0)  THEN 
lER  -  .TRUE. 

RETURN 
END  IF 

CALL  SGESL  (A,  MATDIM,  N,  IPVT,  SAVE2,  0) 

ELSE  IF  (MITER  .EQ.  4  .OR.  MITER  .EQ.  5)  THEN 

CALL  FA  (N,  T,  Y,  A(ML+1,1),  MATDIM,  ML.  MU,  NDE) 

IF  (N  .EQ.  0)  THEN 
JSTATE  -  9 
RETURN 
END  IF 
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CALL  SGBFA  (A,  MATDIM,  N,  ML,  MU,  IPVT,  INFO) 

IF  (INFO  .NE.  0)  THEN 
lER  -  .TRUE. 

RETURN 
END  IF 

CALL  SGBSL  (A,  MATDIM,  N,  ML,  MU,  IPVT,  SAVE2 ,  0) 

END  IF 

ELSE  IF  (IMPL  .EQ.  2)  THEN 

CALL  FA  (N,  T,  Y,  A,  MATDIM,  ML,  MU,  NDE) 

IF  (N  .EQ.  0)  THEN 
J STATE  -  9 
RETURN 
END  IF 

DO  150  I  -  1,NDE 

IF  (A(I,1)  .EQ.  O.EO)  THEN 
lER  -  .TRUE. 

RETURN 

ELSE 

SAVE2(I)  -  SAVE2(I)/A(I,1) 

END  IF 

150  CONTINUE 

DO  155  I  -  NDE+1,N 
155  A(I,1)  -  O.EO 

END  IF 
END  IF 

DO  170  I  -  l.NDE 

170  SAVEl(I)  -  SAVE2(I)/YWT(I) 

SUM  -  SNRM2(NDE,  SAVEl,  1) 

SUMO  -  l.E0/MAX(l.E0,  ABS(T)) 

SMAX  -  MAX(SUM0,  SUM) 

SMIN  -  MIN (SUMO,  SUM) 

SUM  -  SMAX*SQRT(1.E0  +  (SMIN/SMAX)**2)/SQRT(REAL(NDE) ) 

H  -  SIGN(MIN(2.E0*EPS/SUM,  ABS(H)),  H) 

DO  180  I  -  1,N 

180  YH(I,2)  -  H*SAVE2(I) 

IF  (MITER  .EQ.  2  .OR.  MITER  .EQ.  5  .OR.  ISWFLG  .EQ.  3)  THEN 
DO  20  I  -  1,N 

20  FAC (I)  -  SQRT(UROUND) 

END  IF 
ELSE 

IF  (MITER  .NE.  MTROLD)  THEN 
MTROLD  -  MITER 
RC  -  O.EO 
CONVRG  -  .FALSE. 

END  IF 

IF  (MINT  .NE.  MNTOLD)  THEN 
MNTOLD  -  MINT 
OLDLO  -  EL(1,NQ) 

CALL  SDCST  (MAXORD,  MINT,  ISWFLG,  EL,  TQ) 

RC  -  RC*EL(1,NQ) /OLDLO 
NWAIT  -  NQ  +  2 
END  IF 

IF  (H  .NE.  HOLD)  THEN 
NWAIT  -  NQ  +  2 
RH  -  H/HOLD 

CALL  SDSCL  (HMAX,  N,  NQ,  RMAX,  HOLD,  RC,  RH,  YH) 
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END  IF 
END  IF 
END 

SUBROUTINE  SDNTP  (H.K.N.NQ.T.TOUT.YH, Y) 

C***BEGIN  PROLOGUE  SDNTP 
C***REFER  to  SDRIV3 

C  Subroutine  SDNTP  interpolates  the  K-th  derivative  of  Y  at  TOUT, 

C  using  the  data  in  the  YH  array.  If  K  has  a  value  greater  than  NQ, 
C  the  NQ-th  derivative  is  calculated. 

C***ROUTINES  CALLED  (NONE) 

C***DATE  WRITTEN  790601  (YYMMDD) 

C***REVISION  DATE  870216  (YYMMDD) 

C***CATEGORY  NO.  I1A2,I1A1B 

c***author  kahaner,  d.  k.,  national  bureau  of  standards, 

C  SUTHERLAND ,  C .  D . .  LOS  ALAMOS  NATIONAL  LABORATORY 

C***END  PROLOGUE  SDNTP 

REAL  FACTOR,  H,  R,  T,  TOUT,  Y(*) ,  YH(N,*) 

C***FIRST  EXECUTABLE  STATEMENT  SDNTP 
IF  (K  .EQ.  0)  THEN 
DO  10  I  -  1,N 
10  Y(I)  -  YH(I,NQ+1) 

R  -  ((TOUT  -  T)/H) 

DO  20  JJ  -  1,NQ 
J  -  NQ  +  1  -  JJ 
DO  20  I  -  1,N 

20  Y(I)  -  YH(I,J)  +  R*Y(1) 

ELSE 

KUSED  -  MIN(K,  NQ) 

FACTOR  -  l.EO 
DO  40  KK  -  1, KUSED 

40  FACTOR  -  FACTOR*REAL(NQ+l-KK) 

DO  50  I  -  1,N 

50  Y(I)  -  FACTOR*YH(I,NQ+l) 

DO  80  JJ  -  KUSED+1,NQ 
J  -  K  +  1  +  NQ  -  JJ 
FACTOR  -  l.EO 

DO  60  KK  -  1, KUSED 

60  FACTOR  -  FACTOR*REAL(J-KK) 

DO  70  I  -  1,N 

70  Y(I)  -  FACTOR*YH(I,J)  +  R*Y(I) 

80  CONTINUE 

DO  100  I  -  1,N 

100  Y(I)  -  Y(I)*H**( -KUSED) 

END  IF 
END 

REAL  FUNCTION  SDOT(N,SX,INCX.SY, INCY) 

C 

C  RETURNS  THE  DOT  PRODUCT  OF  SINGLE  PRECISION  SX  AND  SY. 

C  SDOT  -  SUM  FOR  I  -  0  TO  N-1  OF  SX(LX+I*INCX)  *  SY(LY+I*INCY) , 

C  WHERE  LX  -  1  IF  INCX  .GE.  0,  ELSE  LX  -  (-INCX)*N,  AND  LY  IS 

C  DEFINED  IN  A  SIMILAR  WAY  USING  INCY. 

C 

REAL  SX(1),SY(1) 

SDOT  -  O.OEO 
IF(N.LE.O)RETURN 

IF(INCX.EQ.INCY)  IF( INCX- 1)5, 20, 60 
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5  CONTINUE 


C 

C  CODE  FOR  UNEQUAL  INCREMENTS  OR  NONPOSITIVE  INCREMENTS. 

C 

IX  -  1 
lY  -  1 

IF(INCX.LT.O)IX  -  (-N+1)*INCX  +  1 
IF(INCY.LT.O)IY  -  (-N+1)*INCY  +  1 
DO  10  I  -  1,N 

SDOT  -  SDOT  +  SX(IX)*SY(IY) 

IX  -  IX  +  INCX 
lY  -  lY  +  INCY 
10  CONTINUE 
RETURN 
C 

C  CODE  FOR  BOTH  INCREMENTS  EQUAL  TO  1 

C 

C 

C  CLEAN-UP  LOOP  SO  REMAINING  VECTOR  LENGTH  IS  A  MULTIPLE  OF  5. 

C 

20  M  -  MOD(N,5) 

IF(  M  .EQ.  0  )  GO  TO  40 
DO  30  I  -  1,M 

SDOT  -  SDOT  +  SX(I)*SY(I) 

30  CONTINUE 

IF(  N  .LT.  5  )  RETURN 
40  MPl  -  M  +  1 

DO  50  I  -  MP1,N,5 

SDOT  -  SDOT  +  SX(I)*SY(I)  +  SX(I  +  1)*SY(I  +  1)  + 

1  SX(I  +  2)*SY(I  +  2)  +  SX(I  +  3)*SY(I  +  3)  +  SX(I  +  4)*SY(I  +  4) 
50  CONTINUE 
RETURN 
C 

C  CODE  FOR  POSITIVE  EQUAL  INCREMENTS  .NE.l. 

C 

60  CONTINUE 
NS-N*INCX 
DO  70  I-1,NS,1NCX 

SDOT  -  SDOT  +  SX(I)*SY(I) 

70  CONTINUE 
RETURN 
END 

SUBROUTINE  SDPSC  (KSGN,N,NQ,YH) 

C***BEGIN  PROLOGUE  SDPSC 
C***REFER  TO  SDRIV3 

C  This  subroutine  computes  the  predicted  YH  values  by  effectively 

C  multiplying  the  YH  array  by  the  Pascal  triangle  matrix  when  KSGN 

C  is  +1,  and  performs  the  inverse  function  when  KSGN  is  -1. 
C***ROUTINES  CALLED  (NONE) 

C***daTE  written  790601  (YYMMDD) 

C***REVISION  DATE  841119  (YYMMDD) 

C***CATEG0RY  no.  I1A2,I1A1B 

C***AUTH0R  KAHANER,  D.  K. ,  NATIONAL  BUREAU  OF  STANDARDS, 

C  SUTHERLAND,  C.  D. ,  LOS  ALAMOS  NATIONAL  LABORATORY 

C***END  PROLOGUE  SDPSC 
REAL  YH(N,*) 
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C***FIRST  EXECUTABLE  STATEMENT  SDPSC 
IF  (KSGN  .GT.  0)  THEN 
DO  10  J1  -  1,NQ 
DO  10  J2  -  Jl.NQ 
J  -  NQ  -  J2  +  J1 
DO  10  I  -  l.N 

10  VH(I,J)  -  YHd.J)  +  YH(I,J+1) 

ELSE 

DO  30  J1  -  l.NQ 
DO  30  J2  -  Jl.NQ 
J  -  NQ  -  J2  +  J1 
DO  30  I  -  1,N 

30  YH(I,J)  -  YH(1,J)  -  YH(I,J+1) 

END  IF 
RETURN 
END 

SUBROUTINE  SGBFA ( ABD . LDA , N , ML , MU . IPVT , INFO ) 

C***BEGIN  PROLOGUE  SGBFA 
C***DATE  written  780814  (YYMMDD) 

C***REVISION  DATE  820801  (YYMMDD) 

C***CATEGORY  NO .  D2A2 

C***KEYWORDS  BANDED , FACTOR . LINEAR  ALGEBRA , LINPACK , MATRIX 
C***AUTH0R  MOLER,  C.  B..  (U.  of  new  MEXICO) 

C***PURPOSE  Factors  a  real  BAND  matrix  by  elimination. 

C***DESCRIPTION 

C 

C  SGBFA  factors  a  real  band  matrix  by  elimination, 

C 

C  SGBFA  is  usually  called  by  SBGCO,  but  it  can  be  called 

C  directly  with  a  saving  in  time  if  RCOND  is  not  needed. 

C 

C  LINPACK.  This  version  dated  08/14/78  . 

C  Cleve  Moler,  University  of  New  Mexico,  Argonne  National  Lab. 

C 

C  Subroutines  and  Functions 

C 

C  BLAS  SAXPY.SSCAL.ISAMAX 

C  Fortran  MAXO.MINO 

C***REFERENCES  DONGARRA  J.J.,  BUNCH  J.R.,  MOLER  C.B. ,  STEWART  G.W., 
C  *LINPACK  USERS  GUIDE*,  SIAM,  1979. 

C***ROUTINES  CALLED  I SAMAX , SAXPY , SSCAL 
C***END  PROLOGUE  SGBFA 

INTEGER  LDA,N,ML,MU,IPVT(1) ,INF0 
REAL  ABD(LDA,1) 

C 

REAL  T 

INTEGER  I,ISAMAX,IO,J,JU,JZ,JO,Jl,K,KPi,L,LM,M,MM,NMl 
C 

C***FIRST  EXECUTABLE  STATEMENT  SGBFA 
M  -  ML  +  MU  +  1 
INFO  -  0 
C 

C  ZERO  INITIAL  FILL-IN  COLUMNS 
C 

JO  -  MU  +  2 

J1  -  MIN0(N,M)  -  1 
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IF  (J1  .LT.  JO)  GO  TO  30 
DO  20  JZ  -  JO,  J1 
10  -  M  +  1  -  JZ 
DO  10  I  -  10.  ML 
ABDd.JZ)  -  O.OEO 
10  CONTINUE 
20  CONTINUE 
30  CONTINUE 
JZ  -  J1 
JU  -  0 

GAUSSIAN  ELIMINATION  WITH  PARTIAL  PIVOTING 
NMl  -  N  -  1 

IF  (NMl  .LT.  1)  GO  TO  130 
DO  120  K  -  1,  NMl 
KPl  -  K  +  1 

ZERO  NEXT  FILL-IN  COLUMN 
JZ  -  JZ  +  1 

IF  (JZ  .GT.  N)  GO  TO  50 
IF  (ML  .LT.  1)  GO  TO  50 
DO  40  I  -  1,  ML 

ABD(I,JZ)  -  O.OEO 
40  CONTINUE 

50  CONTINUE 

FIND  L  -  PIVOT  INDEX 

LM  -  MIN0(ML,N-K) 

L  -  ISAMAX(LM+1,ABD(M,K) ,1)  +  M  -  1 
IPVT(K)  -  L  +  K  -  M 

ZERO  PIVOT  IMPLIES  THIS  COLUMN  ALREADY  TRIANGULARIZED 

IF  (ABD(L,K)  .EQ.  O.OEO)  GO  TO  100 

INTERCHANGE  IF  NECESSARY 

IF  (L  .EQ.  M)  GO  TO  60 
T  -  ABD(L,K) 

ABD(L,K)  -  ABD(M,K) 

ABD(M,K)  -  T 
60  CONTINUE 

COMPUTE  MULTIPLIERS 

T  -  -1.0E0/ABD(M,K) 

CALL  SSCAL(LM,T,ABD(M+1,K) ,1) 

ROW  ELIMINATION  WITH  COLUMN  INDEXING 

JU  -  MINO(MAXO(JU,MU+IPVT(K)),N) 

MM  -  M 

IF  (JU  .LT.  KPl)  GO  TO  90 
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DO  80  J  -  KPl,  JU 
L  -  L  -  1 
MM  -  MM  -  1 
T  -  ABD(L,J) 

IF  (L  .EQ.  MM)  GO  TO  70 
ABD(L,J)  -  ABD(MM,J) 

ABD(MM,J)  -  T 
70  CONTINUE 

CALL  SAXPY(LM,T,ABD(M+1,K) , 1 , ABD(MM+1 , J) , 1) 

80  CONTINUE 

90  CONTINUE 

GO  TO  110 
100  CONTINUE 

INFO  -  K 
110  CONTINUE 

120  CONTINUE 
130  CONTINUE 
IPVT(N)  -  N 

IF  (ABD(M,N)  .EQ.  O.OEO)  INFO  -  N 

RETURN 

END 

SUBROUTINE  SDPST  ( EL , F , FA , H , IMPL , JACOBN , MATDIM , MITER . ML , MU , N , NDE , 
8  NQ,SAVE2,T.USERS,Y,YH,YWT,UROUND,NFE,NJE,A,DFDY,FAC,IER,IPVT, 

8  SAVE1,ISWFLG,BND,JSTATE) 

C***BEGIN  PROLOGUE  SDPST 
C***REFER  TO  SDRIV3 

C  Subroutine  SDPST  is  called  to  reevaluate  the  partials . 

C  If  MITER  is  1.  2,  4,  or  5,  the  matrix 

C  P  -  I  -  L(0)*H*Jacobian  is  stored  in  DFDY  and  subjected  to  LU 
C  decomposition,  with  the  results  also  stored  in  DFDY. 

C***ROUTINES  CALLED  SGEFA,SGBFA,SNRM2 
C***DATE  WRITTEN  790601  (YYMMDD) 

C***REVISION  DATE  870401  (YYMMDD) 

C***CATEGORY  NO.  I1A2,I1A1B 

C***AUTH0R  KAHANER,  D.  K. ,  NATIONAL  BUREAU  OF  STANDARDS, 

C  SUTHERLAND,  C.  D.,  LOS  ALAMOS  NATIONAL  LABORATORY 

C***END  PROLOGUE  SDPST 

REAL  A(MATDIM,*) ,  BL,  BND,  BP,  BR,  BU,  DFDY(MATDIM,*) , 

8  DFDYMX,  DIFF,  DY,  EL(13,12),  FAC(*),  FACMAX,  FACMIN,  FACTOR, 
8  H,  SAVE1(*),  SAVE2(*),  SCALE,  SNRM2 ,  T,  UROUND,  Y(*) , 

8  YH(N,*),  YJ,  YS,  YWT(*) 

INTEGER  IPVT(*) 

LOGICAL  lER 

PARAMETER (FACMAX  -  .5E0) 

C***FIRST  EXECUTABLE  STATEMENT  SDPST 
NJE  -  NJE  +  1 
lER  -  .FALSE. 

IF  (MITER  .EQ.  1  .OR.  MITER  .EQ.  2)  THEN 
IF  (MITER  .EQ.  1)  THEN 

CALL  JACOBN  (N,  T,  Y,  DFDY,  MATDIM,  ML,  MU) 

IF  (N  .EQ.  0)  THEN 
J STATE  -  8 
RETURN 
END  IF 

IF  (ISWFLG  .EQ.  3)  BND  -  SNRM2(N*N,  DFDY,  1) 

FACTOR  -  -EL(1,NQ)*H 
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110 


120 


140 

C 

150 

C 

C 

C 


DO  110  J  -  l.N 
DO  110  I  -  l.N 

DFDY(I,J)  -  FACTOR*DFDY(I,J) 

ELSE  IF  (MITER  .EQ.  2)  THEN 
BR  -  l]ROUND**(.875EO) 

BI  -  UROUND**( .75E0) 

BL  -  UROUND**( .25E0) 

BP  -  UROUND**(- .15E0) 

FACMIN  -  UROUND**(.78EO) 

DO  170  J  -  l.N 

YS  -  MAX(ABS(YVn:(J))  ,  ABS(Y<J))) 

DY  -  FAC(J)*YS 

IF  (DY  .EQ.  O.EO)  THEN 

IF  (FAC(J)  .LT.  FACMAX)  THEN 

FAC(J)  -  MIN(100.E0*FAC(J) ,  FACMAX) 

GO  TO  120 
ELSE 
DY  -  YS 
END  IF 
END  IF 

IF  (NQ  .EQ.  1)  THEN 

DY  -  SIGN(DY,  SAVE2(J)) 

ELSE 

DY  -  SIGN(DY,  YH(J,3)) 

END  IF 

DY  -  (Y(J)  +  DY)  -  Y(J) 

YJ  -  Y(J) 

Y(J)  -  Y(J)  +  DY 
CALL  F  (N,  T,  Y,  SAVEl) 

IF  (N  .EQ.  0)  THEN 
J STATE  -  6 
RETURN 
END  IF 
Y(J)  -  YJ 

FACTOR  -  -EL(1,NQ)*H/DY 
DO  140  I  -  l.N 

DFDYd.J)  -  (SAVEl(I)  -  SAVE2 ( I ) ) *FACTOR 

Step  1 

DIFF  -  ABS(SAVE2(1)  -  SAVEl (1)) 

IMAX  -  1 
DO  150  I  -  2,N 

IF  (ABS(SAVE2(I)  -  SAVEl (I))  .GT.  DIFF)  THEN 
IMAX  -  I 

DIFF  -  ABS(SAVE2(I)  -  SAVEl(I)) 

END  IF 
CONTINUE 

Step  2 

IF  (MIN(ABS(SAVE2(IMAX)) ,  ABS ( SAVEl ( IMAX) ) )  .GT.  O.EO)  THEN 
SCALE  -  MAX(ABS(SAVE2(IMAX)) ,  ABS ( SAVEl ( IMAX) ) ) 

Step  3 

IF  (DIFF  .GT.  BU*SCALE)  THEN 

FAC(J)  -  MAX(FACMIN,  FAC(J)*.1E0) 

ELSE  IF  (BR*SCALE  .LE.  DIFF  .AND.  DIFF  .LE.  BL*SCALE)  THEN 
FAC(J)  -  MIN(FAC(J)*10.E0,  FACMAX) 

Step  4 

ELSE  IF  (DIFF  .LT.  BR*SCALE)  THEN 
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FAC(J)  -  MIN(BP*FAC(J) ,  FACMAX) 

END  IF 
END  IF 

170  CONTINUE 

IF  (ISWFLG  .EQ.  3)  BND  -  SNRM2(N*N,  DFDY,  l)/( -EL(1 .NQ)*H) 
NFE  -  NFE  +  N 
END  IF 

IF  (IMPL  .EQ.  0)  THEN 
DO  190  I  -  l.N 

190  DFDY(I,I)  -  DFDY(I.I)  +  l.EO 

ELSE  IF  (IMPL  .EQ.  1)  THEN 

CALL  FA  (N,  T.  Y,  A,  MATDIM,  ML,  MU,  NDE) 

IF  (N  .EQ.  0)  THEN 
J STATE  -  9 
RETURN 
END  IF 

DO  210  J  -  1,N 
DO  210  I  -  1,N 

210  DFDY(I,J)  -  DFDY(I,J)  +  A(I,J) 

ELSE  IF  (IMPL  .EQ.  2)  THEN 

CALL  FA  (N,  T,  Y,  A,  MATDIM,  ML,  MU,  NDE) 

IF  (N  .EQ.  0)  THEN 
J STATE  -  9 
RETURN 
END  IF 

DO  230  I  -  1,NDE 

230  DFDY(I,I)  -  DFDY(I,I)  +  A(I,1) 

END  IF 

CALL  SGEFA  (DFDY,  MATDIM,  N,  IPVT,  INFO) 

IF  (INFO  .NE.  0)  lER  -  .TRUE. 

ELSE  IF  (MITER  .EQ.  4  .OR.  MITER  .EQ.  5)  THEN 
IF  (MITER  .EQ.  4)  THEN 

CALL  JACOBN  (N,  T,  Y,  DFDY(ML+1 , 1) ,  MATDIM,  ML,  MU) 

IF  (N  .EQ.  0)  THEN 
J STATE  -  8 
RETURN 
END  IF 

FACTOR  -  -EL(1,NQ)*H 
MW  -  ML  +  MU  +  1 
DO  260  J  -  1,N 

11  -  MAX(ML+1,  MW+l-J) 

12  -  MIN(MW+N-J,  MW+ML) 

DO  260  I  -  11,12 

260  DFDY(1,J)  -  FACTOR*DFDY(I,J) 

ELSE  IF  (MITER  .EQ.  5)  THEN 
BR  -  UROUND**(.875EO) 

BL  -  UROUND**( .75E0) 

BU  -  UROUND**(.25EO) 

BP  -  UROUND**(- .15E0) 

FACMIN  -  UROUND**(.78EO) 

MW  -  ML  +  MU  +  1 
J2  -  MIN(MW,  N) 

DO  340  J  -  1,J2 
DO  290  K  -  J,N,MW 

YS  -  MAX(ABS(YWT(K)) ,  ABS(Y(K))) 

280  DY  -  FAC(K)*YS 
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290 


300 

C 


310 

C 

C 


IF  (DY  .EQ.  O.EO)  THEN 

IF  (FAC(K)  .LT.  FACMAX)  THEN 

FAC(K)  -  MIN(100.E0*FAC(K).  FACMAX) 

GO  TO  280 
ELSE 
DY  -  YS 
END  IF 
END  IF 

IF  (NQ  .EQ.  1)  THEN 

DY  -  SIGN(DY.  SAVE2(K)) 

ELSE 

DY  -  SIGN(DY.  YH(K.3)) 

END  IF 

DY  -  (Y(K)  +  DY)  -  Y(K) 

DFDY(MW,K)  -  Y(K) 

Y(K)  -  Y(K)  +  DY 
CALL  F  (N,  T,  Y,  SAVEl) 

IF  (N  .EQ.  0)  THEN 
J STATE  -  6 
RETURN 
END  IF 

DO  330  K  -  i.N.MW 
Y(K)  -  DFDY(MW,K) 

YS  -  MAX(ABS(YWT(K)) ,  ABS(Y(K))) 

DY  -  FAC(K)*YS 

IF  (DY  .EQ.  O.EO)  DY  -  YS 

IF  (NQ  .EQ.  1)  THEN 

DY  -  SIGN(DY,  SAVE2(K)) 

ELSE 

DY  -  SIGN(DY,  YH(K,3)) 

END  IF 

DY  -  (Y(K)  +  DY)  -  Y(K) 

FACTOR  -  -EL(1,NQ)*H/DY 

11  -  MAX(ML+1,  MW+l-K) 

12  -  MIN(MW+N-K,  MW+ML) 

DO  300  I  -  11,12 

13  -  K  +  I  -  MW 

DFDYd.K)  -  FACT0R*( SAVEl (13)  -  SAVE2(I3)) 

Step  1 

IMAX  -  MAX(1,  K  -  MU) 

DIFF  -  ABS(SAVE2(IMAX)  -  SAVEl (IMAX)) 

11  -  IMAX 

12  -  MIN(K  +  ML,  N) 

DO  310  I  -  11+1,12 

IF  (ABS(SAVE2(I)  -  SAVEl(I))  .GT.  DIFF)  THEN 
IMAX  -  I 

DIFF  -  ABS(SAVE2(I)  -  SAVEl(I)) 

END  IF 
CONTINUE 

Step  2 

IF  (MIN (ABS(SAVE2( IMAX)),  ABS ( SAVEl ( IMAX) ) )  .GT.O.EO)  THEN 
SCALE  -  MAX(ABS(SAVE2(IMAX)),  ABS ( SAVEl ( IMAX) ) ) 

Step  3 

IF  (DIFF  .GT.  BU+SCALE)  THEN 

FAC(K)  -  MAX(FACMIN,  FAC(K)*.1E0) 

ELSE  IF  (BR*SCALE  .LE.DIFF  .AND.  DIFF  .LE.BL*SCALE)  THEN 
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FAC(K)  -  MIN(FAC(K)*10.E0,  FACMAX) 

C  Step  4 

ELSE  IF  (DIFF  .LT.  BR*SCALE)  THEN 
FAC(K)  -  MIN(BP*FAC(K) .  FACMAX) 

END  IF 
END  IF 

330  CONTINUE 

340  CONTINUE 

NFE  -  NFE  +  J2 
END  IF 

IF  (ISWFLG  .EQ.  3)  THEN 
DFDYMX  -  O.EO 
DO  345  J  -  1,N 

11  -  MAX(ML+1.  MW+l-J) 

12  -  MIN(MW+N-J,  MW+ML) 

DO  345  I  -  11,12 

345  DFDYMX  -  MAX(DFDYMX.  ABS(DFDY(I , J) ) ) 

BND  -  O.EO 

IF  (DFDYMX  .NE.  O.EO)  THEN 
DO  350  J  -  l.N 

11  -  MAX(ML+1,  MW+l-J) 

12  -  MIN(MW+N-J,  MW+ML) 

DO  350  I  -  11,12 

350  BND  -  BND  +  (DFDY(I , J)/DFDYMX)**2 

BND  -  DFDYMX*SQRT(BND)/(-EL(l,NQ)*H) 

END  IF 
END  IF 

IF  (IMPL  .EQ.  0)  THEN 
DO  360  J  -  1,N 

360  DFDY(MW,J)  -  DFDY(MW,J)  +  l.EO 

ELSE  IF  (IMPL  .EQ.  1)  THEN 

CALL  FA  (N,  T,  Y,  A(ML+1,1),  MATDIM,  ML,  MU,  NDE) 

IF  fN  .EQ.  0)  THEN 
J STATE  -  q 
RETURN 
END  IF 

DO  380  J  -  1,N 

11  -  MAX(ML+1,  MW+l-J) 

12  -  MIN(MW+N-J,  MW+ML) 

DO  380  I  -  11,12 

380  DFDY(I,J)  -  DFDY(I,J)  +  A(I,J) 

ELSE  IF  (IMPL  .EQ.  2)  THEN 

CALL  FA  (N,  T,  Y,  A,  MATDIM,  ML,  MU,  NDE) 

IF  (N  .EQ.  0)  THEN 
J STATE  -  9 
RETURN 
END  IF 

DO  400  J  -  1,NDE 

400  DFDY(MW,J)  -  DFDY(MW,J)  +  A(J,1) 

END  IF 

CALL  SGBFA  (DFDY,  MATDIM,  N,  ML,  MU,  I PVT,  INFO) 

IF  (INFO  .NE.  0)  lER  -  .TRUE. 

ELSE  IF  (MITER  .EQ.  3)  THEN 
IFLAG  -  1 

CALL  USERS  (Y,  YH(1,2),  YWT,  SAVEl ,  SAVE 2 ,  T,  H,  EL(1,NQ),  IMPL, 
8  N,  NDE,  IFLAG) 
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IF  (N  .EQ.  0)  THEN 
J STATE  -  10 
RETURN 
END  IF 
END  IF 
END 

SUBROUTINE  SDRIVl  (N, T .Y, TOUT .MSTATE , EPS .WORK, LENW) 
C***BEGiN  PROLOGUE  SDRIVl 
C***DATE  written  790601  (YYMMDD) 

C***REVISION  DATE  870401  (YYMMDD) 

C***CATEGORY  NO.  IlA2,IlAlB 

C***KEYWORDS  ODE , STIFF. ORDINARY  DIFFERENTIAL  EQUATIONS. 

C  INITIAL  VALUE  PROBLEMS .GEAR' S  METHOD. 

C  SINGLE  PRECISION 

C***AUTH0R  KAHANER.  D.  K..  NATIONAL  BUREAU  OF  STANDARDS, 

C  SUTHERLAND .  C .  D . .  LOS  ALAMOS  NATIONAL  LABORATORY 

C***PURPOSE  The  function  of  SDRIVl  is  to  solve  N  (200  or  fewer) 

C  ordinary  differential  equations  of  the  form 

C  dY(I)/dT  -  F(Y(I),T).  given  the  initial  conditions 

C  Y(I)  -  YI .  SDRIVl  uses  single  precision  arithmetic. 

C***DESCRIPTION 
C 

C  Version  87.1 


C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


I.  CHOOSING  THE  CORRECT  ROUTINE  . 

SDRIV 

DDRIV 

CDRIV 

These  are  the  generic  names  for  three  packages  for  solving 
initial  value  problems  for  ordinary  differential  equations. 
SDRIV  uses  single  precision  arithmetic.  DDRIV  uses  double 
precision  arithmetic.  CDRIV  allows  complex-valued 
differential  equations,  integrated  with  respect  to  a  single, 
real,  independent  variable. 

As  an  aid  in  selecting  the  proper  program,  the  following  is  a 
discussion  of  the  important  options  or  restrictions  associated  with 
each  program: 

A.  SDRIVl  should  be  tried  first  for  those  routine  problems  with 
no  more  than  200  differential  equations.  Internally  this 
routine  has  two  important  technical  defaults: 

1.  Numerical  approximation  of  the  Jacobian  matrix  of  the 
right  hand  side  is  used. 

2.  The  stiff  solver  option  is  used. 

Most  users  of  SDRIVl  should  not  have  to  concern  themselves 
with  these  details. 

B.  SDRIV2  should  be  considered  for  those  problems  for  which 
SDRIVl  is  inadequate  (SDRIV2  has  no  explicit  restriction  on 
the  number  of  differential  equations.)  For  examtile ,  SDRIVl 
may  have  difficulty  with  problems  having  zero  initial 
conditions  and  zero  derivatives.  In  this  case  SDRIV2 ,  with  an 
appropriate  value  of  the  parameter  EWT,  should  perform  more 
efficiently.  SDRIV2  provides  three  important  additional 
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C  options; 

C  1.  The  nonstiff  equation  solver  (as  well  as  the  stiff 

C  solver)  is  available. 

C  2.  The  root- finding  option  is  available. 

C  3.  The  program  can  dynamically  select  either  the  non- stiff 

C  or  the  stiff  methods. 

C  Internally  this  routine  also  defaults  to  the  numerical 

C  approximation  of  the  Jacobian  matrix  of  the  right  hand  side. 

C 

C  C.  SDRIV3  is  the  most  flexible,  and  hence  the  most  complex,  of 

C  the  programs.  Its  important  additional  features  include: 

C  1.  The  ability  to  exploit  band  structure  in  the  Jacobian 

C  matrix. 

C  2.  The  ability  to  solve  some  implicit  differential 

C  equations,  i.e.,  those  having  the  form; 

C  A(Y,T)*dY/dT  -  F(Y,T). 

C  3.  The  option  of  integrating  in  the  one  step  mode. 

C  4.  The  option  of  allowing  the  user  to  provide  a  routine 

C  which  computes  the  analytic  Jacobian  ma:rix  of  the  right 

C  hand  side. 

C  5 .  The  option  of  allowing  the  user  to  provide  a  routine 

C  which  does  all  the  matrix  algebra  associated  with 

C  corrections  to  the  solution  components. 

C 

C 

C***REFERENCES  GEAR,  C.  W. ,  "NUMERICAL  INITIAL  VALUE  PROBLEMS  IN 
C  ORDINARY  DIFFERENTIAL  EQUATIONS",  PRENTICE -HALL,  1971. 

C***ROUTINES  CALLED  SDR31,XERR0R 
C***END  PROLOGUE  SDRIVl 
EXTERNAL  F 

REAL  EPS,  EWT,  HMAX,  T,  TOUT,  WORK(*) ,  Y(*) 

PARAMETER(MXN  -  200,  IDLIW  -  21,  MXLIW  -  IDLIW  +  MXN) 

INTEGER  IWORK(MXLIW) 

CHARACTER  MSG*103 

PARAMETER (NROOT  -  0,  EWT  -  l.EO,  lERROR  -  2,  MINT  -  2,  MITER  -  2. 

8  IMPL  -  0,  MXORD  -  5,  MXSTEP  -  1000) 

C***FIRST  EXECUTABLE  STATEMENT  SDRIVl 
IF  (N  .GT.  MXN)  THEN 

WRITE(MSG,  ' ( "  SDRIV115FE  Illegal  input.  The  number  of  "  , 

8  ''equations,'',  18,  '',  is  greater  than  the  maximum  allowed.'') 

8  ')  N 

CALL  XERROR(MSG(l;97),  97,  15,  2) 

RETURN 
END  IF 

IF  (MSTATE  .GT.  0)  THEN 
NSTATE  -  MSTATE 
NTASK  -  1 
ELSE 

NSTATE  -  -  MSTATE 
NTASK  -  3 
END  IF 

HMAX  -  2.E0*ABS(TOUT  -  T) 

LENIW  -  N  +  IDLIW 
LENWCM  -  LENW  -  LENIW 

IF  (LENWCM  .LT.  (N*N  +  10*N  +  204))  THEN 
LNWCHK  -  N*N  +  10*N  +  204  +  LENIW 


113 


WRITE(MSG,  ' ( ' ' SDRIV116FE  Insufficient  storage  allocated  for 
8  ''the  work  array.  The  required  storage  is  at  least'',  18)') 

8  LNWCHK 

CALL  XERROR(MSG( 1:103 ) ,  103,  16,  2) 

RETURN 
END  IF 

IF  (NSTATE  .NE.  1)  THEN 
DO  20  I  -  1,LENIW 
II  -  I  +  LENWCM 

20  IWORK(I)  -  INT(WORK(II)) 

END  IF 

CALL  SDR31  (N,  T,  Y,  F,  NSTATE,  TOUT,  NTASK,  NROOT,  EPS,  EWT, 

8  lERROR,  MINT,  MITER,  IMPL,  MXORD,  HMAX,  WORK,  LENWCM, 

8  IWORK,  LENIW,  MXSTEP) 

DO  40  I  -  1, LENIW 
II  -  LENWCM  +  I 

40  WORK(II)  -  REAL(IWORK(I)) 

IF  (NSTATE  .LE.  4)  THEN 

MSTATE  -  S1GN(NSTATE,  MSTATE) 

ELSE  IF  (NSTATE  .EQ.  6)  THEN 
MSTATE  -  SIGN(5,  MSTATE) 

END  IF 
END 

SUBROUTINE  SDRIV2  (N ,T ,Y, F ,TOUT , MSTATE ,NROOT , EPS , EWT ,MINT , WORK, 

8  LENW, IWORK, LENIW, G) 

C***BEGIN  PROLOGUE  SDRIV2 
C***DATE  WRITTEN  790601  (YYMMDD) 

C***REVISION  DATE  870401  (YYMMDD) 

C***CATEGORY  NO.  I1A2,I1A1B 

C***KEYWORDS  ODE, STIFF, ORDINARY  DIFFERENTIAL  EQUATIONS, 

C  INITIAL  VALUE  PROBLEMS , GEAR'S  METHOD, 

C  SINGLE  PRECISION 

C***AUTH0R  KAHANER,  D.  K. ,  NATIONAL  BUREAU  OF  STANDARDS, 

C  SUTHERLAND ,  C .  D . ,  LOS  ALAMOS  NATIONAL  LABORATORY 

C***PURP0SE  The  function  of  SDRIV2  is  to  solve  N  ordinary  differential 
C  equations  of  the  form  dY(I)/dT  -  F(Y(I),T),  given  the 

C  initial  conditions  Y(I)  -  YI.  The  program  has  options  to 

C  allow  the  solution  of  both  stiff  and  non-stiff  differential 

C  equations.  SDRIV2  uses  single  precision  arithmetic. 

C***DESCRIPTION 
C 

C  I .  ABSTRACT  . 

C 

C  The  function  of  SDRIV2  is  to  solve  N  ordinary  differential 

C  equations  of  the  form  dY(I)/dT  -  F(Y(I),T),  given  the  initial 

C  conditions  Y(I)  -  YI .  The  program  has  options  to  allow  the 

C  solution  of  both  stiff  and  non- stiff  differential  equations. 

C  SDRIV2  is  to  be  called  once  for  each  output  point  of  T. 

C 

C***REFERENCES  gear,  C.  W. ,  "NUMERICAL  INITIAL  VALUE  PROBLEMS  IN 
C  ORDINARY  DIFFERENTIAL  EQT'nTIONS",  PRENTICE -HALL,  1971. 

C***ROUTINES  CALLED  SDR32,  XERROR 
C***END  PROLOGUE  SDRIV2 
EXTERNAL  F,  G 

REAL  EPS,  EWT,  EWTCOM(l) ,  G,  HMAX,  T,  TOUT, 
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8  WORK(*) ,  Y(*) 

INTEGER  IWORK(*) 

CHARACTER  MSG*81 

PARAMETER (IMPL  -  0,  MXSTEP  -  1000) 

C***FIRST  EXECUTABLE  STATEMENT  SDRIV2 

IF  (MINT  .LT.  1  .OR.  MINT  .GT.  3)  THEN 

WRITE(MSG,  '("SDRIV21FE  Illegal  input.  Improper  value  for  ", 

8  ' ' the  integration  method  flag, ' ' ,  18) ' )  MINT 

CALL  XERROR(MSG(l:81) .  81,  21,  2) 

RETURN 
END  IF 

IF  (MSTATE  .GE.  0)  THEN 
NSTATE  -  MSTATE 
NTASK  -  1 
ELSE 

NSTATE  -  -  MSTATE 
NTASK  -  3 
END  IF 

EWTCOM(l)  -  EWT 
IF  (EWT  .NE.  O.EO)  THEN 
I ERROR  -  3 
ELSE 

I ERROR  -  2 
END  IF 

IF  (MINT  .EQ.  1)  THEN 
MITER  -  0 
MXORD  -  12 

ELSE  IF  (MINT  .EQ.  2)  THEN 
MITER  -  2 
MXORD  -  5 

ELSE  IF  (MINT  .EQ.  3)  THEN 
MITER  -  2 
MXORD  -  12 
END  IF 

HMAX  -  2.E0*ABS(T0UT  -  T) 

CALL  SDR32  (N,  T,  Y,  F,  NSTATE,  TOUT,  NTASK,  NROOT,  EPS,  EWTCOM, 

8  lERROR,  MINT,  MITER,  IMPL,  MXORD,  HMAX,  WORK,  LENW, 

8  IWORK,  LENIW,  MXSTEP,  G) 

IF  (MSTATE  .GE.  0)  THEN 
MSTATE  -  NSTATE 
ELSE 

MSTATE  -  -  NSTATE 
END  IF 
END 

SUBROUTINE  SDRIV3  (N,T ,Y,F, NSTATE, TOUT, NTASK, NROOT, EPS , EWT, lERROR, 
8  MINT , MITER , IMPL , ML , MU , MXORD , HMAX , WORK , LENW , IWORK , LENIW , J ACOBN , 

8  FA, NDE, MXSTEP, G, USERS) 

C***BEGIN  PROLOGUE  SDRIV3 
C***DATE  written  790601  (YYMMDD) 

C***REVISION  DATE  870401  (YYMMDD) 

C***CATEGORY  NO.  I1A2,I1A1B 

C***KEYWORDS  ODE, STIFF, ORDINARY  DIFFERENTIAL  EQUATIONS, 

C  INITIAL  VALUE  PROBLEMS, GEAR'S  METHOD, 

C  SINGLE  PRECISION 

C***AUTH0R  KAHANER,  D.  K. ,  NATIONAL  BUREAU  OF  STANDARDS, 

C  SUTHERLAND,  C.  D. ,  LOS  ALAMOS  NATIONAL  LABORATORY 


C***PURPOSE  The  function  of  SDRIV3  is  to  solve  N  ordinary  differential 
C  equations  of  the  form  dY(I)/dT  -  F(Y(I),T),  given  the 

C  initial  conditions  Y(I)  -  YI .  The  program  has  options  to 

C  allow  the  solution  of  both  stiff  and  non- stiff  differential 

C  equations .  Other  important  options  are  available .  SDRIV3 

C  uses  single  precision  arithmetic. 

C***DESCRIPTION 

C 

C  I .  ABSTRACT  . 

C 

C  The  primary  function  of  SDRIV3  is  to  solve  N  ordinary  differential 

C  equations  of  the  form  dY(I)/dT  -  F(Y(I),T),  given  the  initial 

C  conditions  Y(I)  -  YI.  The  program  has  options  to  allow  the 

C  solution  of  both  stiff  and  non-stiff  differential  equations.  In 

C  addition,  SDRIV3  may  be  used  to  solve; 

C  1.  The  initial  value  problem,  A*dY(I)/dT  -  F(Y(I),T),  where  A  is 

C  a  non- singular  matrix  depending  on  Y  and  T. 

C  2.  The  hybrid  differential/algebraic  initial  value  problem, 

C  A*dY(l)/dT  -  F(Y(I),T),  where  A  is  a  vector  (whose  values  may 

C  depend  upon  Y  and  T)  some  of  whose  components  will  be  zero 

C  corresponding  to  those  equations  which  are  algebraic  rather 

C  than  differential. 

C  SDRIV3  is  to  be  called  once  for  each  output  point  of  T. 

C 

C***REFERENCES  GEAR,  C.  W. ,  "NUMERICAL  INITIAL  VALUE  PROBLEMS  IN 
C  ORDINARY  DIFFERENTIAL  EQUATIONS",  PRENTICE -HALL,  1971. 

C***R0UT1NES  CALLED  SDSTP , SDNTP , SDZRO , SGEFA , SGESL , SGBFA , SGBSL , SNRM2 , 

C  RIMACH.XERROR 

C***END  PROLOGUE  SDRIV3 

ENTRY  SDR31  (N,T, Y, F.NSTATE, TOUT, NTASK,NROOT, EPS , EWT, I ERROR, MINT, 

8  MITER , IMPL , MXORD , HMAX , WORK , LENW , IWORK , LENIW , MXSTEP) 

ENTRY  SDR32  (N,T,Y, F.NSTATE, TOUT, NTASK,NROOT, EPS , EWT, lERROR, MINT, 

8  MITER , IMPL , MXORD , HMAX , WORK , LENW, IWORK , LENIW , MXSTEP , G) 

EXTERNAL  F,  JACOBN,  FA,  G,  USERS 

REAL  AE,  BIG,  EPS,  EWT(*) ,  G,  GLAST,  H,  HMAX,  HSIGN, 

8  NROUND,  RE,  RIMACH,  SIZE,  SNRM2,  SUM,  T,  TLAST,  TOUT,  TROOT, 

8  UROUND,  WORK(*).  Y(*) 

INTEGER  IWORK(*) 

LOGICAL  CONVRG 
CHARACTER  MSG*205 
PARAMETER (NROUND  -  20. EO) 

PARAMETER ( I AVGH  -  1,  IHUSED  -  2,  lAVGRD  -  3, 

8  lEL  -  4,  IH  -  160,  IHMAX  -  161,  IHOLD  -  162, 

8  IHSIGN  -  163,  IRC  -  164,  IRMAX  -  165,  IT  -  166, 

8  ITOUT  -  167,  ITQ  -  168,  ITREND  -  204,  lYH  -  205, 

8  INDMXR  -  1,  INQUSD  -  2,  INSTEP  -  3,  INFE  -  4,  INJE  -  5, 

8  INROOT  -  6,  ICNVRG  -  7,  IJROOT  -  8,  IJTASK  -  9, 

8  IMNTLD  -  10,  IMTRLD  -  11,  INQ  -  12,  INRTLD  -  13, 

8  INDTRT  -  14,  INWAIT  -  15,  IMNT  -  16,  IMTRSV  -  17, 

8  IMTR  -  18,  IMXRDS  -  19,  IMXORD  -  20) 

PARAMETER (INDPRT  -  21,  INDPVT  -  22) 

C***FIRST  EXECUTABLE  STATEMENT  SDRIV3 
NPAR  -  N 

UROUND  -  RIMACH  (4) 

IF  (NROOT  .NE.  0)  THEN 
AE  -  RlMACH(l) 
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c 

c 


RE  -  UROUND 
END  IF 

IF  (EPS  .LT.  O.EO)  THEN 

WRITE(MSG,  '("SDRIV36FE  Illegal  input.  EPS,",  E16.8, 

8  ",  is  negative.")')  EPS 

CALL  XERROR(MSG(1:60) ,  60,  6,  2) 

RETURN 
END  IF 

IF  (N  .LE.  0)  THEN 

WRITE(MSG,  '("SDRIV37FE  Illegal  input.  Number  of  equations,", 
8  18,  is  not  positive.'')')  N 

CALL  XERROR(MSG(l:72) ,  72,  7,  2) 

RETURN 
END  IF 

IF  (MXORD  .LE.  0)  THEN 

WRITE(MSG,  '("SDRIV314FE  Illegal  input.  Maximum  order,  "  ,  18, 

8  '  '  ,  is  not  positive .'')')  MXOEID 

CALL  XERROR(MSG(l:67) ,  67,  14,  2) 

RETURN 
END  IF 

IF  ((MINT  .LT.  1  .OR.  MINT  .GT.  3)  .OR.  (MINT  .EQ.  3  .AND. 

8  (MITER  .EQ.  0  .OR.  MITER  .EQ.  3  .OR.  IMPL  .NE.  0)) 

8  .OR.  (MITER  .LT.  0  .OR.  MITER  .GT.  5)  .OR. 

8  (IMPL  .NE.  0  .AND.  IMPL  .NE.  1  .AND.  IMPL  .NE.  2)  .OR. 

8  ((IMPL  .EQ.  1  .OR.  IMPL  .EQ.  2)  .AND.  MITER  .EQ.  0)  .OR. 

8  (IMPL  .EQ.  2  .AND.  MINT  .EQ.  1)  .OR. 

8  (NSTATE  .LT.  1  .OR.  NSTATE  .GT.  10))  THEN 

WRITE(MSG,  ' ( ' ' SDRIV39FE  Illegal  input.  Improper  value  for  '', 

8  " NSTATE (MSTATE),  MINT,  MITER  or  IMPL.")') 

CALL  XERROR(MSG(l:81),  81,  9,  2) 

RETURN 
END  IF 

IF  (MITER  .EQ.  0  .OR.  MITER  .EQ.  3)  THEN 
LIWCHK  -  INDPVT  -  1 

ELSE  IF  (MITER  .EQ.  1  .OR.  MITER  .EQ.  2  .OR.  MITER  .EQ.  4  .OR. 

8  MITER  .EQ.  5)  THEN 

LIWCHK  -  INDPVT  +  N  -  1 
END  IF 

IF  (LENIW  .LT.  LIWCHK)  THEN 

WRITE(MSG,  '("SDRIV310FE  Illegal  input.  Insufficient  ", 

8  ''storage  allocated  for  the  IWORK  array.  Based  on  the  '')') 
WRITE (MSG ( 94; ) ,  '(''value  of  the  input  parameters  involved,  '', 

8  ''the  required  storage  is'',  18)')  LIWCHK 
CALL  XERROR(MSG( 1:164),  164,  10,  2) 

RETURN 
FJJD  IF 

Allocate  the  WORK  array 
lYH  is  the  index  of  YH  in  WORK 
IF  (MINT  .EQ.  1  .OR.  MINT  .EQ.  3)  THEN 
MAXORD  -  MIN (MXORD,  12) 

ELSE  IF  (MINT  .EQ.  2)  THEN 
MAXORD  -  MIN (MXORD,  5) 

END  IF 

IDFDY  -  lYH  +  (MAXORD  +  1)*N 


C 

C 
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IDFDY  is  the  index  of  DFDY 


c 

c 

c 

c 

c 

c 


c 


c 


IF  (MITER  .EQ.  0  .OR.  MITER  .EQ.  3)  THEN 
lYWT  -  IDFDY 

ELSE  IF  (MITER  .EQ.  1  .OR.  MITER  .EQ.  2)  THEN 
lYWT  -  IDFDY  +  N*N 

ELSE  IF  (MITER  .EQ.  4  .OR.  MITER  .EQ.  5)  THEN 
lYWT  -  IDFDY  +  (2*ML  +  MU  +  1)*N 
END  IF 

lYUT  is  the  index  of  YWT 

ISAVEl  -  lYWT  +  N 

ISAVEl  is  the  index  of  SAVEl 

1SAVE2  -  ISAVEl  +  N 

ISAVE2  is  the  index  of  SAVE2 

IGNOW  -  ISAVE2  +  N 

IGNOW  is  the  index  of  GNOW 

ITROOT  -  IGNOW  +  NROOT 

ITROOT  is  the  index  of  TROOT 

IFAC  -  ITROOT  +  NROOT 

IFAC  is  the  index  of  FAC 

IF  (MITER  .EQ.  2  .OR.  MITER  .EQ.  5  .OR.  MINT  .EQ.  3)  THEN 
lA  -  IFAC  +  N 
ELSE 

lA  -  IFAC 
END  IF 

lA  is  the  index  of  A 

IF  (IMPL  .EQ.  0  .OR.  MITER  .EQ.  3)  THEN 
LENCHK  -  lA  -  1 

ELSE  IF  (IMPL  .EQ.  1  .AND.  (MITER  .EQ.  1  .OR.  MITER  .EQ.  2))  THEN 
LENCHK  -  lA  -  1  +  N*N 

ELSE  IF  (IMPL  .EQ.  1  .AND.  (MITER  .EQ.  4  .OR.  MITER  .EQ.  5))  THEN 
LENCHK  -  lA  -  1  +  (2*ML  +  MU  +  1)*N 
ELSE  IF  (IMPL  .EQ.  2  .AND.  MITER  .NE.  3)  THEN 
LENCHK  -  lA  -  1  +  N 
END  IF 

IF  (LENW  .LT.  LENCHK)  THEN 

WRITE(MSG,  '("SDRIV38FE  Illegal  input.  Insufficient 
8  ''storage  allocated  for  the  WORK  array.  Based  on  the  '')') 
WRITE(MSG(92 : ) ,  '(''value  of  the  input  parameters  involved,  '', 

8  ''the  required  storage  is'',  18)')  LENCHK 
CALL  XERROR(MSG( 1:162 ) ,  162,  8,  2) 

RETURN 
END  IF 

IF  (MITER  .EQ.  0  .OR.  MITER  .EQ.  3)  THEN 
MATDIM  -  1 

ELSE  IF  (MITER  .EQ.  1  .OR.  MITER  .EQ.  2)  THEN 
MATDIM  -  N 

ELSE  IF  (MITER  .EQ.  4  .OR.  MITER  .EQ.  5)  THEN 
MATDIM  -  2*ML  +  MU  +  1 
END  IF 

IF  (IMPL  .EQ.  0  .OR.  IMPL  .EQ.  1)  THEN 
NDECOM  -  N 

ELSE  IF  (IMPL  .EQ.  2)  THEN 
NDECOM  -  NDE 
END  IF 

IF  (NSTATE  .EQ.  1)  THEN 

Initialize  parameters 

IF  (T  .EQ.  TOUT)  RETURN 
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o  o  o 


IF  (MINT  .EQ.  1  .OR.  MINT  .EQ.  3)  THEN 
IWORK(IMXORD)  -  MIN(MXORD,  12) 

ELSE  IF  (MINT  .EQ.  2)  THEN 
IWORK(IMXORD)  -  MIN(MXORD,  5) 

END  IF 

IWORK(IMXRDS)  -  MXORD 
IF  (MINT  .EQ.  1  .OR.  MINT  .EQ.  2)  THEN 
IWORK(IMNT)  -  MINT 
IWORK(IMTR)  -  MITER 
IWORK(IMNTLD)  -  MINT 
IWORK(IMTRLD)  -  MITER 
ELSE  IF  (MINT  .EQ.  3)  THEN 
IWORK(IMNT)  -  1 
IWORK(IMTR)  -  0 
IWORK(IMNTLD)  -  IWORK(IMNT) 
IWORK(IMTRLD)  -  IWORK(IMTR) 
IWORK(IMTRSV)  -  MITER 
END  IF 

WORK(IHMAX)  -  HMAX 
H  -  (TOUT  -  T)*(1.E0  -  4.EO*UROUND) 

H  -  SIGN(MIN(ABS(H) ,  HMAX),  H) 

WORK(IH)  -  H 

HSIGN  -  SIGNd.EO,  H) 

WORK(IHSIGN)  -  HSIGN 
IWORK(IJTASK)  -  0 
WORK(IAVGH)  -  O.EO 
WORK(IAVGRD)  -  O.EO 
IWORK(INQUSD)  -  0 
IWORK( INSTEP)  -  0 
IWORK(INFE)  -  0 
IWORK(INJE)  -  0 
WORK(IT)  -  T 
IWORK(ICNVRG)  -  0 
IWORK(INDPRT)  -  0 

DO  30  I  -  l.N 

JYH  -  I  +  lYH  -  1 
30  WORK(JYH)  -  Y(I) 

GO  TO  180 
END  IF 


IF  (IWORK(ICNVRG)  .EQ.  1)  THEN 
CONVRG  -  .TRUE. 

ELSE 

CONVRG  -  .FALSE. 

END  IF 
T  -  WORK(IT) 

H  -  WORK(IH) 

HSIGN  -  WORK(IHSIGN) 

IF  (IWORK(IJTASK)  .EQ.  0)  GO  TO  180 
C 

C  IWORK(IJROOT)  flags  unreported 

C  roots,  and  is  set  to  the  value  of 

C  NTASK  when  a  root  was  last  selected. 


Set  initial  conditions 


On  a  continuation,  check 
that  output  points  have 
been  or  will  be  overtaken. 
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non  DO  o  o 


C 

C 

C 

C 

C 

C 

C 

C 

C 


It  is  set  to  zero  when  all  roots 
have  been  reported.  1W0RK( INROOT) 
contains  the  index  and  WORK(ITOUT) 
contains  the  value  of  the  root  last 
selected  to  be  reported. 
IWORK(INRTLD)  contains  the  value  of 
NROOT  and  IWORK(INDTRT)  contains 
the  value  of  ITROOT  when  the  array 
of  roots  was  last  calculated. 

IF  (NROOT  .NE.  0)  THEN 
JROOT  -  IWORK(IJROOT) 

IF  (JROOT  .GT.  0)  THEN 

TOUT  has  just  been  reported. 

If  TROOT  .LE.  TOUT,  report  TROOT. 

IF  (NSTATE  .NE.  5)  THEN 

IF  (TOUT*HSIGN  .GE.  WORK(ITOUT)*HSIGN)  THEN 
TROOT  -  WORK(ITOUT) 

CALL  SDNTP(H.  0,  N,  IWORK(INQ),  T,  TROOT,  WORK(IYH) ,  Y) 

T  -  TROOT 
NSTATE  -  5 
GO  TO  580 
END  IF 

A  root  has  just  been  reported. 

Select  the  next  root. 

ELSE 

TROOT  -  T 
IROOT  -  0 

DO  50  I  -  1,IW0RK(INRTLD) 

JTROOT  -  IWORK(INDTRT)  +1-1 
IF  (WORK(JTROOT)*HSIGN  .LE.  TROOT*HSIGN)  THEN 


Check  for  multiple  roots. 


IF  (WORK(JTROOT)  .EQ.  WORK(ITOUT)  .AND. 

8  I  .GT.  IW0RK( INROOT))  THEN 

IROOT  -  I 

TROOT  -  WORK(JTROOT) 

GO  TO  60 
END  IF 

IF  (WORK(JTROOT)*HSIGN  .GT.  WORK(ITOUT)*HSIGN)  THEN 
IROOT  -  I 

TROOT  -  WORK(JTROOT) 

END  IF 
END  IF 

50  CONTINUE 

60  IWORK( INROOT)  -  IROOT 

WORK(ITOUT)  -  TROOT 

IWORK(IJROOT)  -  NTASK 

IF  (NTASK  .EQ.  1)  THEN 
IF  (IROOT  .EQ.  0)  THEN 
IWORK(IJROOT)  -  0 
ELSE 

IF  (TOUT*HSIGN  .GE.  TROOT*HSIGN)  THEN 

CALL  SDNTP(H,  0,  N,  IWORK(INQ) ,  T,  TROOT, WORK ( I YH )  ,Y) 
NSTATE  -  5 
T  -  TROOT 
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c 

C 

C 

C 

C 


C 


GO  TO  580 
END  IF 
END  IF 

ELSE  IF  (NTASK  .EQ.  2  .OR.  NTASK  .EQ.  3)  THEN 

If  there  are  no  more  roots ,  or  the 
user  has  altered  TOUT  to  be  less 
than  a  root,  set  IJROOT  to  zero. 

IF  (IROOT  .EQ.  0  .OR.  (TOUT*HSIGN  .LT.  TROOT*HSIGN) )  THEN 
I WORK (IJROOT)  -  0 
ELSE 

CALL  SDNTP(H,  0,  N,  IWORK(INQ),  T,  TROOT,  WORK(IYH).  Y) 
NSTATE  -  5 
T  -  TROOT 
GO  TO  580 
END  IF 
END  IF 
END  IF 
END  IF 
END  IF 

IF  (NTASK  .EQ.  1)  THEN 
NSTATE  -  2 

IF  (T*HSIGN  .GE.  TOUT*HSIGN)  THEN 

CALL  SDNTP  (H,  0,  N,  IWORK(INQ) ,  T,  TOUT,  WORK(IYH) ,  Y) 

T  -  TOUT 
GO  TO  580 
END  IF 

ELSE  IF  (NTASK  .EQ.  2)  THEN 

Check  if  TOUT  has 
been  reset  .LT.  T 

IF  (T*HSIGN  .GT.  TOUT*HSIGN)  THEN 

WRITE(MSG,  '  ("SDRIV32WRN  With  NTASK-"  ,  II,  "  on  input,  ", 

8  "T,",  E16.8,  ",  was  beyond  TOUT, "  ,  E16.8,  ".  Solution", 

8  "  obtained  by  interpolation.")')  NTASK,  T,  TOUT 

CALL  XERROR(MSG(l: 124) ,  124,  2,  0) 

CALL  SDNTP  (H,  0,  N,  IWORK(INQ),  T,  TOUT,  WORK(IYH) ,  Y) 

T  -  TOUT 
NSTATE  -  2 
GO  TO  580 
END  IF 

Determine  if  TOUT  has  been  overtaken 


IF  (ABS(TOUT  -  T) .LE.NROUND*UROUND*MAX(ABS(T) ,  ABS(TOUT)))  THEN 
T  -  TOUT 
NSTATE  -  2 
GO  TO  560 
END  IF 

If  there  are  no  more  roots 
to  report,  report  T. 

IF  (NSTATE  .EQ.  5)  THEN 
NSTATE  -  2 
GO  TO  560 
END  IF 
NSTATE  -  2 
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o  o  on 


See  if  TOUT  will 
be  overtaken. 

IF  ((T  +  H)*HSIGN  .GT.  TOUT*HSIGN)  THEN 
H  -  TOUT  -  T 

IF  ((T  +  H)*HSIGN  .GT.  TOUT*HSIGN)  H  -  H*(1.E0  -  4.E0*UR0UND) 
WORK(IH)  -  H 

IF  (H  .EQ.  O.EO)  GO  TO  670 
IWORK(IJTASK)  -  -1 
END  IF 

ELSE  IF  (NTASK  .EQ.  3)  THEN 
NSTATE  -  2 

IF  (T*HSIGN  .GT.  TOUT*HSIGN)  THEN 

WRITE(MSG,  '  ("SDRIV32WRN  With  NTASK- "  ,  II,  "  on  input,  ", 

8  "T,",  E16.8,  ",  was  beyond  TOUT,  "  ,  E16.8,  ".  Solution", 

8  "  obtained  by  interpolation.")')  NTASK,  T,  TOUT 

CALL  XERROR(MSG(l: 124) ,  124,  2,  0) 

CALL  SDNTP  (H,  0,  N,  IWORK(INQ) ,  T,  TOUT,  WORK(IYH) ,  Y) 

T  -  TOUT 
GO  TO  580 
END  IF 

IF  (ABS(T0UT  -  T) .LE.NROUND*UROUND*MAX(ABS(T) ,  ABS(TOUT)))  THEN 
T  -  TOUT 
GO  TO  560 
END  IF 

IF  ((T  +  H)*HSIGN  .GT.  TOUT*HSIGN)  THEN 
H  -  TOUT  -  T 

IF  ((T  +  H)*HSIGN  .GT.  TOUT*HSIGN)  H  -  H*(1.E0  -  4.EO*UROUND) 
WORK(IH)  -  H 

IF  (H  .EQ.  O.EO)  GO  TO  670 
IWORK(IJTASK)  -  -1 
END  IF 
END  IF 

Implement  changes  in  MINT,  MITER,  and/or  HMAX. 

IF  ((MINT  .NE.  IWORK(IMNTLD)  .OR.  MITER  .NE.  IWORK(IMTRLD) )  .AND. 

8  MINT  .NE.  3  .AND.  IWORK(IMNTLD)  .NE.  3)  IWORK(IJTASK)  -  -1 
IF  (HMAX  .NE.  WORK(IHMAX))  THEN 
H  -  SIGN(MIN(ABS(H) ,  HMAX),  H) 

IF  (H  .NE.  WORK(IH))  THEN 
IWORK(IJTASK)  -  -1 
WORK(IH)  -  H 
END  IF 

WORK(IHMAX)  -  HMAX 
END  IF 
C 

180  NSTEPL  -  IWORK( INSTEP) 

DO  190  I  -  1,N 
JYH  -  lYH  +  I  -  1 
190  Y(I)  -  WORK(JYH) 

IF  (NROOT  .NE.  0)  THEN 
DO  200  I  -  1, NROOT 
JGNOW  -  IGNOW  +1-1 
WORK(JGNOW)  -  G  (NPAR,  T,  Y,  I) 

IF  (NPAR  .EQ.  0)  THEN 
IWORK( INROOT)  -  I 
NSTATE  -  7 
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RETURN 
END  IF 

200  CONTINUE 
END  IF 

IF  (lERROR  .EQ.  1)  THEN 
DO  230  I  -  1,N 

JYWT  -  I  +  lYWT  -  1 

230  WORK(JYWT)  -  l.EO 

GO  TO  410 

ELSE  IF  ULRROR  .EQ.  5)  THEN 
DO  250  I  -  1,N 

JYWT  -  I  +  lYWT  -  1 

250  WORK(JYWT)  -  EWT(I) 

GO  TO  410 
END  IF 

C  Reset  YWT  array.  Looping  point. 

260  IF  (lERROR  .EQ.  2)  THEN 
DO  280  I  -  1,N 

IF  (Y(I)  .EQ.  O.EO)  GO  TO  290 
JYWT  -  I  +  lYWT  -  1 
280  WORK(JYWT)  -  ABS(Y(I)) 

GO  TO  410 

290  IF  (IWORK(IJTASK)  .EQ.  0)  THEN 

CALL  F  (NPAR,  T,  Y,  WORK(ISAVE2) ) 

IF  (NPAR  .EQ.  0)  THEN 
NSTATE  -  6 
RETURN 
END  IF 

IWORK(INFE)  -  IWORK(INFE)  +  1 
IF  (MITER  .EQ.  3  .AND.  IMPL  .NE.  0)  THEN 
IFLAG  -  0 

CALL  USERS (Y,  WORK(IYH),  WORK (I YWT ) ,  WORK(ISAVEl) , 

8  WORK(ISAVE2) ,  T,  H,  WORK(IEL) ,  IMPL,  NPAR, 

8  NDECOM,  IFLAG) 

IF  (NPAR  .EQ.  0)  THEN 
NSTATE  -  10 
RETURN 
END  IF 

ELSE  IF  (IMPL  .EQ.  1)  THEN 

IF  (MITER  .EQ.  1  .OR.  MITER  .EQ.  2)  THEN 

CALL  FA  (NPAR,  T,  Y,  WORK(IA) ,  MATDIM,  ML,  MU,  NDECOM) 

IF  (NPAR  .EQ.  0)  THEN 
NSTATE  -  9 
RETURN 
END  IF 

CALL  SGEFA  (WORK(IA) ,  MATDIM,  N,  IWORK(INDPVT) ,  INFO) 

IF  (INFO  .NE.  0)  GO  TO  690 

CALL  SGESL(WORK(IA) , MATDIM, N, IWORK(INDPVT) , WORK(ISAVE2) , 0) 
ELSE  IF  (MITER  .EQ.  4  .OR.  MITER  .EQ.  5)  THEN 
JAML  -  lA  +  ML 

CALL  FA  (NPAR,  T,  Y,  WORK (J AML ) ,  MATDIM,  ML,  MU,  NDECOM) 

IF  (NPAR  .EQ.  0)  THEN 
NSTATE  -  9 
RETURN 
END  IF 

CALL  SGBFA  (WORK(IA) .MATDIM, N, ML, MU, IWORK(INDPVT) , INFO) 
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IF  (INFO  .NE.  0)  GO  TO  690 

CALL  SGBSL  (WORK(IA),  MATDIM,  N.  ML,  MU,  IWORK(INDPVT) , 

8  WORK(ISAVE2),  0) 

END  IF 

ELSE  IF  (IMPL  .EQ.  2)  THEN 

CALL  FA  (NPAR,  T,  Y,  WORK(IA> ,  MATDIM,  ML,  MU,  NDECOM) 

IF  (NPAR  .EQ.  0)  THEN 
NSTATE  -  9 
RETURN 
END  IF 

DO  340  I  -  1, NDECOM 
JA  -  I  +  lA  -  1 
JSAVE2  -  I  +  ISAVE2  -  1 
IF  (WORK(JA)  .EQ.  O.EO)  GO  10  690 
340  WORK(JSAVE2)  -  WORK(JSAVE2)/WORK(JA) 

END  IF 
END  IF 

DO  360  J  -  I.N 

JYWT  -  J  +  lYWT  -  1 
IF  (Y(J)  .NE.  O.EO)  THEN 
WORK(JYWT)  -  ABS(Y(J)) 

ELSE 

IF  (IWORK(IJTASK)  .EQ.  0)  THEN 
JSAVE2  -  J  +  ISAVE2  -  1 
WORK(JYWT)  -  ABS(H*WORK(JSAVE2)) 

ELSE 

JHYP  -  J  +  lYH  +  N  -  1 
WORK(JYWT)  -  ABS( WORK (JHYP)) 

END  IF 
END  IF 

IF  (WORK(JYWT)  .EQ.  O.EO)  WORK(JYWT)  -  UROUND 
360  CONTINUE 

ELSE  IF  (lERROR  .EQ.  3)  THL 
DO  380  I  -  1,N 

JYWT  -  I  +  lYWT  -  1 

380  WORK(JYWT)  -  MAX(EWT(1) ,  ABS(Y(I))) 

ELSE  IF  (lERROR  .EQ.  4)  THEN 
DO  400  I  -  1,N 

JYWT  -  I  +  lYWT  -  1 

400  WORK(JYWT)  -  MAX(EWT(I) ,  ABS(Y(I))) 

END  IF 

410  DO  420  I  -  1,N 

JYWT  -  I  +  lYWT  -  1 
JSAVE2  -  I  +  ISAVE2  -  1 
420  WORK(JSAVE2)  -  Y(I)/WORK(JYWT) 

SUM  -  SNRM2(N,  WORK(ISAVE2) ,  1)/SQRT(REAL(N) ) 

IF  (EPS  .LT.  SUM*UROUND)  THEN 

EPS  -  SUM*UROUND*(1.EO  +  10 . EO*UROUND) 

WRITE(MSG,  '("SDRIV34REC  At  T,",  E16.8,  ",  the  requested  " 
8  "accuracy,  EPS,  was  not  obtainable  with  the  machine  ", 

8  "precision.  EPS  has  been  increased  to'')')  T 
WRITE(MSG(137:) ,  '(E16.8)')  EPS 
CALL  XERROR(MSG(l: 152) ,  152,  4,  1) 

NSTATE  -  4 
GO  TO  560 
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END  IF 

IF  (ABS(H)  .GE.  UROUND*ABS(T))  THEN 
IWORK(INDPRT)  -  0 

ELSE  IF  (IWORK(INDPRT)  .EQ.  0)  THEN 

WRITE(MSG,  '  ("SDRIV35WRN  At  T,  "  ,  E16.8,  ",  the  step  size , 

8  E16.8,  ",  is  smaller  than  the  roundoff  level  of  T.  ")')  T,  H 

WRITE  (MSG  ( 109 :) ,  '("This  may  occur  if  there  is  an  abrupt 
8  ''change  in  the  right  hand  side  of  the  differentia*  '', 

8  ' ' equations 

CALL  XERR0R(MSG(1: 205) ,  205,  5,  0) 

IWORK(INDPRT)  -  1 
END  IF 

IF  (NTASK.NE.2)  THEN 

IF  (( IWORK( INSTEP )-NSTEPL)  .GT.  MXSTEP)  THEN 

WR1TE(MSG,  '("SDRIV33WRN  At  T,"  ,  E16.8,  ",  ",  13, 

8  ''  steps  have  been  taken  without  reaching  TOUT,'',  E16.8)') 

8  T,  MXSTEP,  TOUT 

CALL  XERROR(MSG( 1:103 ) ,  103,  3,  0) 

NSTATE  -  3 
GO  TO  560 
END  IF 
END  IF 
C 

C  CALL  SDSTP  (EPS,  F,  FA,  HMAX,  IMPL,  JACOBN,  MATDIM,  MAXORD, 

G  8  MINT,  MITER,  ML,  MU,  N,  NDE,  YWT ,  UROUND,  USERS, 

C  8  AVGH,  AVGORD,  H,  HUSED,  JTASK,  MNTOLD,  MTROLD, 

C  8  NFE,  NJE,  NQUSED,  NSTEP,  T,  Y,  YH,  A,  CONVRG, 

C  8  DFDY,  EL,  FAC,  HOLD,  IPVT,  JSTATE,  NQ,  NWAIT,  RC, 

C  8  RMAX,  SAVEl,  SAVE2 ,  TQ,  TREND,  ISWFLG,  MTRSV,  MXRDSV) 

C 

CALL  SDSTP  (EPS,  F,  FA,  WORK (I HMAX ) ,  IMPL,  JACOBN,  MATDIM, 

8  IWORK(IMXORD) ,  IWORK(IMNT),  IWORK(IMTR),  ML,  MU,  NPAR, 

8  NDECOM,  WORK(IYWT),  UROUND,  USERS,  WORK (I AVGH ) , 

8  WORK(IAVGRD) ,  WORK(IH),  WORK (I HUS ED ) ,  IWCRK( IJTASK) , 

8  IWORK(IMNTLD) ,  IWORK( IMTRLD) ,  IWORK(INFE) ,  IWORK(INJE) , 

8  IWORK(INQUSD) ,  IWORK( INSTEP) ,  WORK(IT) ,  Y,  WORK(IYH) , 

8  WORK(IA),  CONVRG,  WORK(IDFDY) ,  WORK(IEL),  WORK (I FAC ) , 

8  WORK(IHOLD),  IWORK(INDPVT) ,  JSTATE,  IWORK(IVQ) , 

8  IW0RK( INWAIT) ,  WORK(IRC) ,  WORK (I RMAX ) ,  WORK(ISAVEl) , 

8  WORK(ISAVE2),  WORK(ITQ),  WORK (I TREND ) ,  MINT, 

8  IWORK(IMTRSV) ,  IWORK(IMXRDS) ) 

T  -  WORK(IT) 

H  -  WORK(IH) 

GO  TO  (470,  670,  680,  690,  690,  660,  660,  660,  660,  660),  JSTATE 
470  IWORK( IJTASK)  -  1 

C  Determine  if  a  root  has  been  overtaken 

IF  (NROOT  .NE.  0)  THEN 
IROOT  -  0 

DO  500  I  -  1, NROOT 

JTROOT  -  ITROOT  +1-1 
JGNOW  -  IGNOW  +1-1 
GLAST  -  WORK (JGNOW) 

WORK( JGNOW)  -  G  (NPAR,  T,  Y,  I) 

IF  (NPAR  .EQ.  0)  THEN 
I WORK (INROOT)  -  I 
NSTATE  -  7 
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END  IF 

IF  (ABS(H)  .GE.  UROUND*ABS(T))  THEN 
IWORK(INDPRT)  -  0 

ELSE  IF  (IWORK(INDPRT)  .EQ.  0)  THEN 

WRITE(MSG,  '  ("SDRIV35WRN  At  T,  "  ,  E16.8,  ",  the  step  size , 

8  E16.8,  ",  is  smaller  than  the  roundoff  level  of  T.  ")')  T,  H 

WRITE<MSG(109 : ) ,  '("This  may  occur  if  there  is  an  abrupt 
8  ''change  in  the  right  hand  side  of  the  differential  '', 

8  ' ' equations .'*)') 

CALL  XERR0R(MSG(1: 205) .  205,  5.  0) 

IWORK(INDPRT)  -  1 
END  IF 

IF  (NTASK.NE.2)  THEN 

IF  ((IWORK(INSTEP)-NSTEPL)  .GT.  MXSTEP)  THEN 

WRITE(MSG,  '  ("SDRIV33WRN  At  T,  "  ,  E16.8,  ",  ",  18, 

8  ''  steps  have  been  taken  without  reaching  TOUT,'',  E16.8)') 

8  T,  MXSTEP,  TOUT 

CALL  XERROR(MSG( 1:103),  103,  3.  0) 

NSTATE  -  3 
GO  TO  560 
END  IF 
END  IF 

CALL  SDSTP 

8 
8 
8 

C  8 
C  8 
C 

CALL  SDSTP 

8 
8 
8 
8 
8 
8 
8 
8 
8 
8 

T  -  WORK(IT) 

H  -  WORK(IH) 

GO  TO  (470,  670,  680,  690,  690,  660,  660,  660,  660,  660),  JSTATE 
470  IWORK(IJTASK)  -  1 

C  Determine  if  a  root  has  been  overtaken 

IF  (NROOT  .NE.  0)  THEN 
IROOT  -  0 

DO  500  I  -  1, NROOT 

JTROOT  -  ITROOT  +1-1 
JGNOW  -  IGNOW  +1-1 
GLAST  -  WORK(JGNOW) 

W0RK( JGNOW)  -  G  (NPAR,  T,  Y,  I) 

IF  (NPAR  .EQ.  0)  THEN 
IW0RK( INROOT)  -  I 
NSTATE  -  7 


(EPS,  F,  FA,  HMAX,  IMPL,  JACOBN,  MATDIM,  MAXORD, 

MINT,  MITER,  ML,  MU,  N,  NDE,  YWT,  UROUND,  USERS, 

AVGH,  AVGORD,  H,  HUSED,  JTASK,  MNTOLD,  MTROLD, 

NFE,  NJE,  NQUSED,  NSTEP,  T,  Y,  YH,  A,  CONVRG, 

DFDY,  EL,  FAC,  HOLD.  IPVT,  JSTATE,  NQ,  NWAIT,  RC, 

RMAX,  SAVEl,  SAVE2,  TQ,  TREND,  ISWFLG,  MTRSV,  MXRDSV) 

(EPS,  F,  FA,  WORK(IHMAX),  IMPL,  JACOBN,  MATDIM, 
IWORK(IMXORD) ,  IWORK(IMNT),  IWORK(IMTR) ,  ML,  MU,  NPAR, 
NDECOM,  WORK(IYWT),  UROUND,  USERS,  WORK(IAVGH) , 
WORK(IAVGRD) ,  WORK(IH),  WORK(IHUSED) ,  IWORK(IJTASK) , 
IWORK(IMNTLD) ,  IWORK(IMTRLD) ,  IWORK(INFE),  IWORK(INJE), 
IWORK(INQUSD) ,  IWORK( INSTEP) ,  WORK(IT) ,  Y.  WORK(IYH) , 
WOR:i(IA),  CONVRG,  WORK(IDFDY),  WORK(IEL) ,  WORK (I FAC ) , 
WORK(iHOLD),  IWORK(INDPVT) ,  JSTATE,  IWORK(INQ) , 

IWORK( INWAIT) ,  WORK(IRC),  WORK (I RMAX ) .  WORK(ISAVEl) , 
WORK(ISAVE2) ,  WORK(ITQ) ,  WORK (I TREND ) ,  MINT, 
IWORK(IMTRSV) ,  IWORK(IMXRDS) ) 
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END  IF 

C  Test  for  NTASK  condition  to  be  satisfied 

NSTATE  -  2 

IF  (NTASK  .EQ.  1)  THEN 

IF  (T*HSIGN  .LT.  TOUT*HSIGN)  GO  TO  260 
CALL  SDNTP  (H,  0,  N,  IWORK(INQ) .  T,  TOUT,  WORK(IYH) ,  Y) 

T  -  TOUT 
GO  TO  580 

TOUT  is  assumed  to  have  been  attained 
exactly  if  T  is  within  twenty  roundoff 
units  of  TOUT,  relative  to  max(TOUT,  T) . 
ELSE  IF  (NTASK  .EQ.  2)  THEN 

IF  (ABS(TOUT  -  T) .LE.NROUND*UROUND*MAX(ABS(T) ,  ABS(TOUT)))  THEN 
T  -  TOUT 
ELSE 

IF  ((T  +  H)*HSIGN  .GT.  TOUT*HSIGN)  THEN 
H  -  TOUT  -  T 

IF  ((T  +  H)*HSIGN.GT.TOUT*HSIGN)  H  -  H*(1.E0  -  4.EO*UROUND) 
WORK(IH)  -  H 

IF  (H  .EQ.  O.EO)  GO  TO  670 
IWORK(IJTASK)  -  -1 
END  IF 
END  IF 

ELSE  IF  (NTASK  .EQ.  3)  THEN 

IF  (ABS(TOUT  -  T) .LE.NROUND*UROUND*MAX(ABS(T) ,  ABS(TOUT)))  THEN 
T  -  TOUT 
ELSE 

IF  ((T  +  H)*HSIGN  .GT.  TOUT*HSIGN)  THEN 
H  -  TOUT  -  T 

IF  ((T  +  H)*HSIGN.GT.TOUT*HSIGN)  H  -  H*(1.E0  -  4.E0*UR0UND) 
WORK(IH)  -  H 

IF  (H  .EQ.  O.EO)  GO  TO  670 
IWORK(IJTASK)  -  -1 
END  IF 
GO  TO  260 
END  IF 
END  IF 

All  returns  are  made  through  this 
section.  IMXERR  is  determined. 

560  DO  570  I  -  1,N 

JYH  -  I  +  lYH  -  1 
570  Y(I)  -  WORK(JYH) 

580  IF  (CONVRG)  THEN 

IWORK(ICNVRG)  -  1 
ELSE 

IWORK(ICNVRC)  -  0 
END  IF 

IF  (IWORK(IJTASK)  .EQ.  0)  RETURN 
BIG  -  O.EO 
IMXERR  -  1 

IWORK(INDMXR)  -  IMXERR 
DO  590  I  -  1,N 

C  SIZE  -  ABS(ERROR(I)/YWT(I)) 

JYWT  -  I  +  lYWT  -  1 
JERROR  -  I  +  ISAVEl  -  1 


SIZE  -  ABS(W0RK(JERR0R)/W0RK(JYWT:; 

IF  (BIG  .LT.  SIZE)  THEN 
BIG  -  SIZE 
IMXERR  -  I 

IWORK(INDMXR)  -  IMXERR 
END  IF 

590  CONTINUE 
RETURN 
C 

660  NSTATE  -  JSTATE 
RETURN 

C  Fatal  errors  are  processed  here 

C 

6/0  WRITE(MSG,  '  ( "  SDRIV311FE  At  T,  "  ,  E16.8,  ",  the  attempted  ", 

8  "step  size  has  gone  to  zero.  Often  this  occurs  if  the  ", 

8  "problem  setup  is  incorrect.")')  T 
CALL  XERROR(MSG(l; 129) ,  129,  11,  2) 

RETURN 

C 

680  WRITE(MSG,  '  (  "  SDRIV312FE  At  T,  "  ,  E16.8,  ",  the  step  size  has"  , 
8  ' '  been  reduced  about  50  times  without  advancing  the  " ) ' )  T 

WRITE (MSG ( 103 :) ,  '(''solution.  Often  this  occurs  if  the  '', 

8  ''problem  setup  is  incorrect.'')') 

CALL  XERR0R(MSG(1: 165) ,  165,  12,  2) 

RETURN 

C 

690  WRITE(MSG,  '  (  "  SDRIV313FE  At  T,  "  ,  E16.8,  ",  while  solving", 

8  "  A*YD0T  -  F,  A  is  singular.")')  T 

CALL  XERR0R(MSG(1;74) ,  74,  13,  2) 

RETURN 

END 

SUBROUTINE  SDSCL  (HMAX,N,NQ,RMAX,H,RC,RH,YH) 

C***BEGIN  PROLOGUE  SDSCL 
C***REFER  TO  SDRIV3 

C  This  subroutine  rescales  the  YH  array  whenever  the  step  size 
C  is  changed. 

C***ROUTINES  CALLED  (NONE) 

C***DATE  WRITTEN  790601  (YYMMDD) 

C***REVISION  DATE  850319  (YYMMDD) 

C***CATEGORY  NO.  IlA2,IlAlB 

C***AUTH0R  KAHANER,  D.  K. ,  NATIONAL  BUREAU  OF  STANDARDS, 

C  SUTHERLAND,  C.  D. ,  LOS  ALAMOS  NATIONAL  LABORATORY 

C***END  PROLOGUE  SDSCL 

REAL  H,  HMAX,  RC,  RH,  RMAX,  Rl,  YH(N,*) 

C***FIRST  EXECUTABLE  STATEMENT  SDSCL 
IF  (H  .LT.  l.EO)  THEN 

RH  -  MIN(ABS(H)*RH,  ABS(H)*RMAX,  HMAX)/ABS(H) 

ELSE 

RH  -  MIN(RH,  RMAX,  HMAX/ABS(H)) 

END  IF 
Rl  -  l.EO 
DO  10  J  -  1,NQ 
Rl  -  R1*RH 
DO  10  I  -  l.N 

10  YH(I,J+1)  -  YH(I,J+1)*R1 

H  -  H*RH 
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RC  -  RC*RH 
END 

SUBROUTINE  SDSTP  (EPS,F,FA,HMAX,IMPL,JACOBN,MATDIM,MAXORD,MINT, 

8  MITER , ML , MU , N . NDE , YWT , UROUND . USERS , AVGH , AVGORD , H , HUSED , JTASK , 

8  MNTOLD , MTROLD , NFE , NJE , NQUSED . NSTEP , T , Y , YH , A , CONVRG , DFDY , EL , FAC , 

8  HOLD , I PVT , J STATE , NQ , NWAIT , RC , RMAX , SAVEl , SAVE2 , TQ , TREND , ISWFLG , 

8  MTRSV.MXRDSV) 

C***BEGIN  PROLOGUE  SDSTP 
C***REFER  TO  SDRIV3 

C  SDSTP  performs  one  step  of  the  integration  of  an  initial  /alue 
C  problem  for  a  system  of  ordinary  differential  equations. 
c***routines  called  SDNTL,SDPST,SDC0R,SDPSC,SDSCL,SNRM2 
C***DATE  WRITTEN  790601  (YYMMDD) 

C***REV1SI0N  DATE  870810  (YYMMDD) 

C***CATEGORY  NO.  I1A2,I1A1B 

C***AUTHOR  KAHANER,  D.  K. ,  NATIONAL  BUREAU  OF  STANDARDS, 

C  SUTHERLAND ,  C .  D . ,  LOS  ALAMOS  NATIONAL  LABORATORY 

C***END  PROLOGUE  SDSTP 

EXTERNAL  F,  JACOBN,  FA.  USERS 

REAL  A(MATDIM,*),  AVGH,  AVGORD,  BIASl,  BIAS2,  BIAS3, 

8  BND,  CTEST,  D,  DENOM,  DFDY(MATDIM,*) ,  Dl,  EL(13,12),  EPS, 

8  ERDN,  ERUP,  ETEST,  FAC(*) ,  H,  HMAX,  HN,  HOLD.  HS ,  HUSED, 

8  NUMER,  RC,  RCTEST,  RH,  RHl,  RH2,  RH3,  RMAX.  RMFAIL,  RMNORM, 

8  SAVE1(*),  SAVE2(*),  SNRM2,  T,  TOLD,  TQ(3,12),  TREND,  TRSHLD, 

8  UROUND,  Y(*),  YH(N,*),  YWT(*) ,  YONlOl 
INTEGER  IPVT(*) 

LOGICAL  CONVRG,  EVALFA,  EVAUC,  lER,  SWITCH 

PARAMETER(BIAS1  -  1.3E0,  BIAS2  -  1.2E0,  BIAS3  -  1.4E0,  MXFAIL  -  3, 
8  MXITER  -  3,  MXTRY  -  50,  RCTEST  -  .3E0,  RMFAIL  -  2.E0, 

8  RMNORM  -  10. EO,  TRSHLD  -  l.EO) 

DATA  lER  /.FALSE./ 

C***FIRST  EXECUTABLE  STATEMENT  SDSTP 
NSV  -  N 
BND  -  O.EO 
SWITCH  -  .FALSE. 

NTRY  -  0 
TOLD  -  T 
NFAIL  -  0 

IF  (JTASK  .LE.  0)  THEN 

CALL  SDNTL  (EPS.  F,  FA,  HMAX,  HOLD,  IMPL,  JTASK,  MATDIM, 

8  MAXORD,  MINT,  MITER,  ML,  MU,  N,  NDE,  SAVEl,  T, 

8  UROUND,  USERS,  Y,  YWT,  H,  MNTOLD,  MTROLD,  NFE,  RC, 

8  YH,  A,  CONVRG,  EL,  FAC,  lER,  IPVT,  NQ,  NWAIT,  RH, 

8  RMAX,  SAVE2,  TQ,  TREND,  ISWFLG,  JSTATE) 

IF  (N  .EQ.  0)  GO  TO  440 
IF  (H  .EQ.  O.EO)  GO  TO  400 
IF  (lER)  GO  TO  420 
END  IF 

100  NTRY  -  NTRY  +  1 

IF  (NTRY  .GT.  MXTRY)  GO  TO  410 
T  -  T  +  H 

CALL  SDPSC  (1,  N,  NQ,  YH) 

EVAUC  -  ((ABS(RC  -  l.EO)  .GT.  RCTEST)  .AND.  (MITER  .NE.  0)) 
EVALFA  -  .NOT.  EVAUC 
C 

110  ITER  -  0 
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C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 
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132 


134 


DO  115  I  -  l.N 
Yd)  -  YHd.l) 

CALL  F  (N.  T,  Y,  SAVE2) 

IF  (N  .EQ.  0)  THEN 
J STATE  -  6 
GO  TO  430 
END  IF 

NFE  -  NFE  +  1 

IF  (EVALJC  .OR.  lER)  THEN 

CALL  SDPST  (EL,  F,  FA,  H,  IMPL,  JACOBN,  MATDIM,  MITER,  ML, 

8  MU,  N,  NDE,  NQ,  SAVE2,  T,  USERS,  Y,  YH,  YWT,  UROUND, 

8  NFE,  NJE,  A,  DFDY,  FAC,  lER,  IPVT,  SAVEl ,  ISWFLG, 

8  END,  JSTATE) 

IF  (N  .EQ.  0)  GO  TO  430 
IF  (lER)  GO  TO  160 
CONVRG  -  .FALSE. 

RC  -  l.EO 
END  IF 

DO  125  I  -  1,N 
SAVEld)  -  O.EO 

Up  to  MXITER  corrector  iterations  are  taken. 
Convergence  is  tested  by  requiring  the  r.m.s. 
norm  of  changes  to  be  less  than  EPS .  The  sum  of 
the  corrections  is  accumulated  in  the  vector 
SAVEl (I).  It  is  approximately  equal  to  the  L-th 
derivative  of  Y  multiplied  by 
H**L/(factorial(L-l)*EL(L,NQ) ) ,  and  is  thus 
proportional  to  the  actual  errors  to  the  lowest 
power  of  H  present  (H**L) .  The  YH  array  is  not 
altered  in  the  correction  loop.  The  norm  of  the 
iterate  difference  is  stored  in  D.  If 
ITER  .GT.  0,  an  estimate  of  the  convergence  rate 
constant  is  stored  in  TREND,  and  this  is  used  in 
the  convergence  test. 


CALL  SDCOR  (DFDY,  EL,  FA,  H,  IMPL,  IPVT,  MATDIM,  MITER,  ML, 

8  MU,  N,  NDE,  NQ,  T,  USERS,  Y,  YH,  YWT,  EVALFA,  SAVEl, 

8  SAVE2,  A,  D,  JSTATE) 

IF  (N  .EQ.  0)  GO  TO  430 
IF  (ISWFLG  .EQ.  3  .AND.  MINT  .EQ.  1)  THEN 
IF  (ITER  .EQ.  0)  THEN 

NUMER  -  SNRM2(N,  SAVEl,  1) 

DO  132  I  -  1,N 

DFDY(1,I)  -  SAVEld) 

YONRM  -  SNRM2(N,  YH,  1) 

ELSE 

DENOM  -  NUMER 
DO  134  I  -  1,N 

DFDY(1,I)  -  SAVEl(I)  -  DFDY(1,1) 

NUMER  -  SNRM2(N,  DFDY,  MATDIM) 

IF  (EL(1,NQ)*NUMER  .LE.  100 . EO*UROUND*YONRM)  THEN 
IF  (RMAX  .EQ.  RMFAIL)  THEN 
SWITCH  -  .TRUE. 

GO  TO  170 
END  IF 
END  IF 
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C 

C 

C 

C 

C 

C 


160 


C 

C 

C 

C 

170 


180 


DO  136  1  -  l.N 

DFDY(l.I)  -  SAVEl(I) 

IF  (DENOM  .NE.  O.EO) 

8  BND  -  MAX(BND,  NUMER/(DENOM*ABS(H)*EL(l ,NQ) ) ) 

END  IF 
END  IF 

IF  (ITER  .GT.  0)  TREND  -  MAX( . 9E0*TREND,  D/Dl) 

D1  -  D 

CTEST  -  MIN(2.E0*TREND,  l.E0)*D 
IF  (CTEST  .LE.  EPS)  GO  TO  170 
ITER  -  ITER  +  1 
IF  (ITER  .LT.  MXITER)  THEN 
DO  140  I  -  l.N 

Y(I)  -  YH(I,1)  +  EL(1,NQ)*SAVE1(I) 

CALL  F  (N,  T,  Y,  SAVE2) 

IF  (N  .EQ.  0)  THEN 
J STATE  -  6 
GO  TO  430 
END  IF 

NFE  -  NFE  +  1 
GO  TO  130 
END  IF 

The  corrector  iteration  failed  to  converge  in 
MXITER  tries.  If  partials  are  involved  but  are 
not  up  to  date,  they  are  reevaluated  for  the  next 
try.  Otherwise  the  YH  array  is  retracted  to  its 
values  before  prediction,  and  H  is  reduced,  if 
possible.  If  not,  a  no-convergence  exit  is  taken. 

IF  (CONVRG)  THEN 
EVALJC  -  .TRUE. 

EVALFA  -  .FALSE. 

GO  TO  110 
END  IF 
T  -  TOLD 

CALL  SDPSC  (-1,  N.  NQ,  YH) 

NWAIT  -  NQ  +  2 

IF  (JTASK  .NE.  0  .AND.  JTASK  .NE.  2)  RMAX  -  RMFAIL 
IF  (ITER  .EQ.  0)  THEN 
RH  -  .3E0 
ELSE 

RH  -  .9E0*(EPS/CTEST)**(.2E0) 

END  IF 

IF  (RH*H  .EQ.  O.EO)  GO  TO  400 

CALL  SDSCL  (HMAX,  N,  NQ,  RMAX.  H,  RC,  RH,  YH) 

GO  TO  100 

The  corrector  has  converged.  CONVRG  is  set 
to  .TRUE,  if  partial  derivatives  were  used, 
to  indicate  that  they  may  need  updating  on 
subsequent  steps.  The  error  test  is  made. 
CONVRG  -  (MITER  .NE.  0) 

DO  180  I  -  1,NDE 

SAVE2(I)  -  SAVE1(I)/YWT(I) 

ETEST  -  SNRM2(NDE,  SAVE2 ,  1)/(TQ(2 ,NQ)*SQRT(REAL(NDE) ) ) 


The  error  test  failed.  NFAIL  keeps  track  of 
multiple  failures.  Restore  T  and  the  YH 
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c 

c 
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array  to  their  previous  values,  and  prepare 
to  try  the  step  again.  Compute  the  optimum 
step  size  for  this  or  one  lower  order. 

IF  (ETEST  .GT.  EPS)  THEN 
T  -  TOLD 

CALL  SDPSC  (-1,  N,  NQ,  YH) 

NFAIL  -  NFAIL  +  1 
IF  (NFAIL  .LT.  MXFAIL)  THEN 

IF  (JTASK  .NE.  0  .AND.  JTASK  .NE.  2)  RMAX  -  RMFAIL 
RH2  -  l.E0/(BIAS2*(ETEST/EPS)**(l.E0/REAL(NQ+l))) 

IF  (NQ  .GT.  1)  THEN 
DO  190  I  -  l.NDE 
190  SAVE2(I)  -  YH(I,NQ+1)/YWT(I) 

ERDN  -  SNRM2(NDE,  SAVE2.  1)/(TQ(1 ,NQ)*SQRT(REAL(NDE) ) ) 

RHl  -  l.EO/MAX(l.EO,  BIAS1*(ERDN/EPS)**(1 . EO/REAL(NQ) ) ) 

IF  (RH2  .LT.  RHl)  THEN 
NQ  -  NQ  -  1 

RC  -  RC*EL(1,NQ)/EL(1,NQ+1) 

RH  -  RHl 
ELSE 

RH  -  RH2 
END  IF 
ELSE 

RH  -  RH2 
END  IF 

NWAIT  -  NQ  +  2 

IF  (RH*H  .EQ.  O.EO)  GO  TO  400 

CALL  SDSCL  (HMAX,  N,  NQ,  RMAX,  H,  RC,  RH,  YH) 

GO  TO  100 
END  IF 

C  Control  reaches  this  section  if  the  error  test  has 

C  failed  MXFAIL  or  more  times.  It  is  assumed  that  the 

C  derivatives  that  have  accumulated  in  the  YH  array  have 

C  errors  of  the  wrong  order.  Hence  the  first  derivative 

C  is  recomputed,  the  order  is  set  to  1,  and  the  step  is 

C  retried. 

NFAIL  -  0 
JTASK  -  2 
DO  215  I  -  1,N 
215  Y(I)  -  YH(I,1) 

CALL  SDNTL  (EPS,  F,  FA,  HMAX,  HOLD,  IMPL,  JTASK,  MATDIM, 

MAXORD,  MINT,  MITER,  ML,  MU,  N,  NDE,  SAVEl,  T, 
UROUND,  USERS,  Y,  YWT,  H,  MNTOLD,  MTROLD,  NFE,  RC, 
YH,  A,  CONVRG,  EL,  FAC,  lER,  IPVT,  NQ,  NWAIT,  RH, 
RMAX,  SAVE2,  TQ,  TREND,  ISWFLG,  J STATE) 

RMAX  -  RMNORM 
IF  (N, .EQ.  0)  GO  TO  440 
IF  (H  .EQ.  O.EO)  GO  TO  400 
IF  (lER)  GO  TO  420 
GO  TO  100 
END  IF 

C  After  a  successful  step,  update  the  YH  array. 

NSTEP  -  NSTEP  +  1 
HUSED  -  H 
NQUSED  -  NQ 

AVGH  -  (REAL(NSTEP-1)*AVGH  +  H)/REAL(NSTEP) 
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AVGORD  -  (REAL(NSTEP-l)*AVGORD  +  REAL(NQ) )/REAL(NSTEP) 

DO  230  J  -  1,NQ+1 
DO  230  I  -  l.N 

230  YH(I,J)  -  +  EL(J,NQ)*SAVE1(I) 

DO  235  1  -  1,N 
235  Y(l)  -  YH(I,1) 

If  ISWFLG  is  3,  consider 
changing  integration  methods. 


IF  (ISWFLG  .EQ.  3)  THEN 
IF  (BND  .NE.  O.EO)  THEN 

IF  (MINT  .EQ.  1  .AND.  NQ  .LE.  5)  THEN 

m?  -  ABS("),-'MA”(UROUND,  (ETEST/EPS)**(1 .  E0/REAL(NQ+'' :  )  ) 
HN  -  MIN(HN,  l.E0/(2.E0*EL(l,NQ)*BND)) 

HS  -  ABS(H)/MAX(UROUND, 

8  (ETEST/(EPS*EL(NQ+1 , 1) ))**(! . E0/REAL(NQ+1) ) ) 

IF  (HS  .GT.  1.2E0*HN)  THEN 
MINT  -  2 
MNTOLD  -  MINT 
MITER  -  MTRSV 
MTROLD  -  MITER 
MAXORD  -  MIN(MXRDSV,  5) 

RC  -  O.EO 
RMAX  -  RMNORM 
TREND  -  l.EO 

CALL  SDCST  (MAXORD,  MINT,  ISWFLG,  EL,  TQ) 

NWAIT  -  NQ  +  2 
END  IF 

ELSE  IF  (MINT  .EQ.  2)  THEN 

HS  -  ABS(H)/MAX(UROUND,  (ETEST/EPS)**(1 . E0/REAL(NQ+1) ) ) 
HN  -  ABS(H)/MAX(UROUND, 

8  (ETEST*EL(NQ+1 , 1)/EPS)**(1 .  E0/RE;AL(NQ+1)  )  ) 

HN  -  MIN(HN,  l.E0/(2.E0*EL(l,NQ)*BND)) 

IF  (HN  .GE.  HS)  THEN 
MINT  -  1 
MNTOLD  -  MINT 
MITER  -  0 
MTROLD  -  MITER 
MAXORD  -  M1N(MXRDSV,  12) 

RMAX  -  RMNORM 
TREND  -  l.EO 
CONVRG  -  .FALSE. 

CALL  SDCST  (MAXORD,  MINT,  ISWFLG,  EL,  TQ) 

NWAIT  -  NQ  +  2 
END  IF 
END  IF 
END  IF 
END  IF 

IF  (SWITCH)  THEN 
MINT  -  2 
MNTOLD  -  MINT 
MITER  -  MTRSV 
MTROLD  -  MITER 
MAXORD  -  MIN(MXRDSV,  5) 

NQ  -  MIN(NQ,  MAXORD) 

RC  -  O.EO 
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c 

c 

c 

c 

c 


250 


C 

C 

C 

C 

C 

0 

C 

C 

C 

C 

C 


270 


290 


RMAX  -  RMNORM 
TREND  -  l.EO 

CALL  SDCST  (MAXORD,  MINT,  ISWFLG,  EL.  TQ) 

NWAIT  -  NQ  +  2 
END  IF 

Consider  changing  H  if  NWAIT  -  1.  Otherwise 
decrease  NWAIT  by  1 .  If  NWAIT  is  then  1  and 
NQ . LT . MAXORD ,  then  SAVEl  is  saved  for  use  in 
a  possible  order  increase  on  the  next  step. 

IF  (JTASK  .EQ.  0  .OR.  JTASK  .EQ.  2)  THEN 

RH  -  l.EO/MAX(UROUND,  BIAS2*(ETEST/EPS)**(1 . E0/REAL(NQ+1) ) ) 

IF  (?“  '^T  TRSHTJ>)  CALL  SDSCL  (HMAX,  N,  NQ,  F.MAV  U,  RC ,  RH,  YH) 
ELSE  IF  (NWAIT  .GT.  1)  THEN 
NWAIT  -  NWAIT  -  1 

IF  (NWAIT  .EQ.  1  .AND.  NQ  .LT.  MAXORD)  THEN 
DO  250  I  -  1,NDE 

YH(I,MAXORD+l)  -  SAVEl(I) 

END  IF 

If  a  change  in  H  is  considered,  an  increase  or  decrease  in 
order  by  one  is  considered  also.  A  change  in  H  is  made 
only  if  it  is  by  a  factor  of  at  least  TRSHLD.  Factors 
RHl,  RH2 ,  and  RH3  are  computed,  by  which  H  could  be 
multiplied  at  order  NQ  -  1 ,  order  NQ,  or  order  NQ  +  1, 
respectively.  The  largest  of  these  is  determined  and  the 
new  order  chosen  accordingly.  If  the  order  is  to  be 
increased,  we  compute  one  additional  scaled  derivative. 

If  there  is  a  change  of  order,  reset  NQ  and  the 
coefficient  In  any  case  H  is  reset  according  to  RH  and 
the  YH  array  is  rescaled. 

ELSE 

IF  (NQ  .EQ.  1)  THEN 
RHl  -  O.EO 
ELSE 

DO  270  I  -  1,NDE 

SAVE2(I)  -  YH(I,NQ+1)/YWT(I) 

ERDN  -  SNRM2(NDE,  SAVE2,  1)/(TQ(1 ,NQ)*SQRT(REAL(NDE) ) ) 

RHl  -  l.E0/MAX(UROUND,  BIAS1*(ERDN/EPS)**(1 . E0/REAL(NQ) ) ) 

END  IF 

RH2  -  l.E0/MAX(UROUND,  BIAS2*(ETEST/EPS)**(1 . E0/REAL(NQ+1) ) ) 

IF  (NQ  .EQ.  MAXORD)  THEN 
RH3  -  O.EO 
ELSE 

DO  290  I  -  l.NDE 

SAVE2(I)  -  (SAVEl(I)  -  YH(I ,MAXORD+l) )/YWT(I) 

ERUP  -  SNRM2(NDE,  SAVE2,  1)/(TQ(3 ,NQ)*SQRT(REAL(NDE) ) ) 

RH3  -  l.E0/MAX(UROUND,  BIAS3*(ERUP/EPS)**(1 . E0/REAL(NQ+2) ) ) 

END  IF 

IF  (RHl  .GT.  RH2  .AND.  RHl  .GE.  RH3)  THEN 
RH  -  RHl 

IF  (RH  .LE.  TRSHLD)  GO  TO  380 
NQ  -  NQ  -  1 

RC  -  RC*EL(1,NQ)/EL(1,NQ+1) 

ELSE  IF  (RH2  .GE.  RHl  .AND.  RH2  .GE.  RH3)  THEN 
RH  -  RH2 

IF  (RH  .LE.  TRSHLD)  GO  TO  380 
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ELSE 

RH  -  RH3 

IF  (RH  .LE.  TRSHLD)  GO  TO  380 
DO  360  I  -  l.N 

360  YH(I,NQ+2)  -  SAVE1(I)*EL(NQ+1 ,NQ)/REAL(NQ+1) 

NQ  -  NQ  +  1 

RC  -  RC*EL(l,NQ)/EL(l.NQ-i) 

END  IF 

IF  (ISWFLG  .EQ.  3  .AND.  MINT  .EQ.  1)  THEN 

IF  (BND.NE.O.EO)  RH  -  MIN(RH,  1. E0/(2 . E0*EL(1 ,NQ)*Z"D*ABS(H) ) ) 
END  IF 

CALL  SDSCL  (HMAX,  N,  NQ,  RMAX,  H,  RC,  RH,  YH) 

RMAX  -  RMNORM 


3fJO  MWATT  -  NQ  +  2 
END  IF 

C  All  returns  are  made  through  this  section.  H  is  saved 

C  in  HOLD  to  allow  the  caller  to  change  H  on  the  next  step 


J STATE  -  1 
HOLD  -  H 
RETURN 
C 

400  JSTATE  -  2 
HOLD  -  H 
DO  405  I  -  l.N 
405  Y(I)  -  YH(I,1) 

RETURN 

C 

410  JSTATE  -  3 
HOLD  -  H 
RETURN 
C 

420  JSTATE  -  4 
HOLD  -  H 
RETURN 
C 

430  T  -  TOLD 

CALL  SDPSC  (-1,  NSV,  NQ,  YH) 

DO  435  I  -  1,NSV 
435  Y(I)  -  YH(I,1) 

440  HOLD  -  H 
RETURN 
END 

SUBROUTINE  SDZRO  (AE,F,H,N,NQ,IROOT,RE,T,YH,UROUND,B,C,FB,FC,Y) 
C***BEGIN  PROLOGUE  SDZRO 
C***REFER  TO  SDRIV3 

C  This  is  a  special  purpose  version  of  ZEROIN,  modified  for  use  with 
C  the  SDRIVl  package. 

C 

C  Sandia  Mathematical  Program  Library 

C  Mathematical  Computing  Services  Division  5422 

C  Sandia  Laboratories 

C  P.  0.  Box  5800 

C  Albuquerque,  New  Mexico  87115 

C  Control  Data  6600  Version  4.5,  1  November  1971 

C 

C  ABSTRACT 
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C  ZEROIN  searches  for  a  zero  of  a  function  F(N,  T,  Y,  IROOT) 

C  between  the  given  values  B  and  C  until  the  width  of  the 

C  interval  (B,  C)  has  collapsed  to  within  a  tolerance  specified 

C  by  the  stopping  criterion,  ABS(B  -  C)  .LE.  2 .*(RW*ABS(B)  +  AE) . 

C 

C  REFERENCES 

C  1.  L  F  Shampine  and  H  A  Watts,  ZEROIN,  A  Root-Solving  Routine, 

C  SC-TM-70-631,  Sept  1970. 

C  2.  T  J  Dekker,  Finding  a  Zero  by  Means  of  Successive  Linear 

C  Interpolation,  "Constructive  Aspects  of  the  Fundamental 

C  Theorem  of  Algebra",  edited  by  B  Dejon  and  P  Henrici,  1969. 

C***ROUTINES  CALLED  SDNTP 
C***DATE  written  790601  (YYMMDD) 

C***REV1SI0N  DATE  870511  (YYMMDD)  ‘ 

C***CATEGORY  NO.  I1A2,I1A1B 

C***AUTHOR  KAHANER,  D.  K. ,  NATIONAL  BUREAU  OF  STANDARDS, 

C  SUTHERLAND,  C.  D. ,  LOS  ALAMOS  NATIONAL  LABORATORY 

C***END  PROLOGUE  SDZRO 

REAL  A,  ACBS,  ACMB,  AE,  R,  C,  CMB,  ER,  F,  FA,  FB,  FC, 

8  H,  P,  Q,  RE,  RW,  T,  TOL,  UROUND,  Y(*) ,  YH(N,*) 

C***FIRST  EXECUTABLE  STATEMENT  SDZRO 
ER  -  4.EO*UROUND 
RW  -  MAX(RE,  ER) 

IC  -  0 

ACBS  -  ABS(B  -  C) 

A  -  C 
FA  -  FC 
KOUNT  -  0 

C  Perform  interchange 

10  IF  (ABS(FC)  .LT.  ABS(FB))  THEN 
A  -  B 
FA  -  FB 
B  -  C 
FB  -  FC 
C  -  A 
FC  -  FA 
END  IF 

CMB  -  0.5E0*(C  -  B) 

ACMB  -  ABS(CMB) 

TOL  -  RW*ABS(B)  +  AE 

C  Test  stopping  criterion 

IF  (ACMB  .LE.  TOL)  RETURN 
IF  (KOUNT  .GT.  50)  RETURN 

C  Calculate  new  iterate  implicitly  as 

C  B  +  P/Q,  where  we  arrange  P  .GE.  0. 

C  The  implicit  form  is  used  to  prevent  overflow. 

P  -  (B  -  A)*FB 
Q  -  FA  -  FB 
IF  (P  .LT.  O.EO)  THEN 
P  -  -P 

Q  -  -Q 

END  IF 

C  Update  A  and  check  for  satisfactory  reduction 

C  in  the  size  of  our  bounding  interval. 

A  -  B 
FA  -  FB 
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Bisect 


C 


C 

C 

C 

C 

C 


C 


C 

C 

20 


C 

C 

C 


IC  -  IC  +  1 
IF  (IC  .GE.  4)  THEN 

IF  (8.E0*ACMB  .GE.  ACBS)  THEN 

B  -  0.5E0*(C  +  B) 

GO  TO  20 
END  IF 
IC  -  0 
END  IF 
ACBS  -  ACMB 

Test  for  too  small  a  change 

IF  (P  .LE.  ABS(Q)*T0L)  THEN 

Increment  by  tolerance 

B  -  B  +  SIGN(T0L,  CMB) 

Root  ought  to  be  between 
B  and  (C  +  B)/2. 

ELSE  IF  (P  .LT.  CMB*Q)  THEN 

Interpolate 

B  -  B  +  P/Q 
ELSE 

Bisect 

B  -  0.5E0*(C  +  B) 

END  IF 

Have  completed  computation 
for  new  iterate  B. 

CALL  SDNTP  (H,  0,  N,  NQ,  T,  B,  YH,  Y) 

FB  -  F(N,  B,  Y,  IROOT) 

IF  (N  .EQ.  0)  RETURN 
IF  (FB  .EQ.  O.EO)  RETURN 
KOUNT  -  KOUNT  +  1 

Decide  whether  next  step  is  interpolation  or  extrapolation 


IF  (SIGNd.OEO,  FB)  .EQ.  SIGN(1.0E0,  FC))  THEN 
C  -  A 
FC  -  FA 
END  IF 
GO  TO  10 
END 

SUBROUTINE  SGBSL ( ABD , LDA , N , ML , MU , I PVT , B , JOB) 

C***BEGIN  PROLOGUE  SGBSL 
C***DATE  WRITTEN  780814  (YYMMDD) 

C***REVISION  DATE  820801  (YYMMDD) 

C***CATEGORY  NO.  D2A2 

C***KEYWORDS  BANDED , LINEAR  ALGEBRA , LINPACK , MATRIX , SOLVE 
C***AUTH0R  MOLER,  C.  B.,  (U.  OF  new  MEXICO) 

C*** purpose  Solves  the  real  BAND  system  A*X-B  or  TRANS(A)*X-B 
C  using  the  factors  computed  by  SGBCO  or  SGBFA. 

C***DESCRIPTION 
C 

C  SGBSL  solves  the  real  band  system 
C  A  *  X  -  B  or  TRANS(A)  *  X  -  B 
C  using  the  factors  computed  by  SBGCO  or  SGBFA. 

C 

C***REFERENCES  DONGARRA  J.J.,  BUNCH  J.R.,  MOLER  C.B. ,  STEWART  G.W., 
C  *LINPACK  USERS  GUID?*,  SIAM,  1979. 


non  nnno  non 


C***ROUTINES  CALLED  SAXPY.SDOT 
C***END  PROLOGUE  SGBSL 

INTEGER  LDA.N,ML,MU,IPVT(1) ,JOB 
REAL  ABD(LDA,1) ,B(1) 

C 

REAL  SDOT.T 

INTEGER  K,KB,L,LA,LB,LM,M,NM1 
C***FIRST  EXECTJTABLE  STATEMENT  SGBSL 
M  -  MU  +  ML  +  1 
NMl  -  N  -  1 

IF  (JOB  .NE.  0)  GO  TO  50 
C 

C  JOB  -  0  ,  SOLVE  A  *  X  -  B 

C  FIRST  SOLVE  L*Y  -  B 

C 

IF  (ML  .EQ.  0)  GO  TO  30 
IF  (NMl  .LT.  1)  GO  TO  30 
DO  20  K  -  1,  NMl 
LM  -  MIN0(ML,N-K) 

L  -  IPVT(K) 

T  -  B(L) 

IF  (L  .EQ.  K)  GO  TO  10 
B(L)  -  B(K) 

B(K)  -  T 

10  CONTINUE 

CALL  SAXPY(LM,T,ABD(M+1,K),1,B(K+1).1) 
20  CONTINUE 

30  CONTINUE 

NOW  SOLVE  U*X  -  Y 

DO  40  KB  -  1,  N 
K  -  N  +  1  -  KB 
B(K)  -  B(K)/ABD(M,K) 

LM  -  MIN0(K,M)  -  1 
LA  -  M  -  LM 
LB  -  K  -  LM 
T  -  B(K) 

CALL  SAXPY(LM,T,ABD(LA,K) ,1,B(LB) ,1) 

40  CONTINUE 

GO  TO  100 
50  CONTINUE 

JOB  -  NONZERO,  SOLVE  TRANS (A)  *  X  -  B 
FIRST  SOLVE  TRANS (U)*Y  -  B 

DO  60  K  -  i,  N 

LM  -  MIN0(K,M)  -  1 
LA  -  M  -  LM 
LB  -  K  -  LM 

T  -  SDOT(LM,ABD(LA,K).l,B(LB),l) 

B(K)  -  (B(K)  -  T)/ABD(M,K) 

60  CONTINUE 

NOW  SOLVE  TRANS (L)*X  -  Y 


IF  (ML  .EQ.  0)  GO  TO  90 
IF  (NMl  .LT.  1)  GO  TO  90 
DO  80  KB  -  1,  NMl 
K  -  i;  -  KB 
LM  -  MIN0(ML,N-K) 

B(K)  -  B(K)  +  SDOT(LM,ABD(M+l,K) ,1,B(K+1) ,1) 

L  -  IPVT(K) 

IF  (L  .EQ.  K)  GO  TO  70 
T  -  B(L) 

B(L)  -  B(K) 

B(K)  -  T 

70  CONTINUE 

80  CONTINUE 

90  CONTINUE 
100  CONTINUE 
RETURN 
END 

SUBROUTINE  SGEFA( A , LDA , N , IPVT , INFO) 

C***BEGIN  PROLOGUE  SGEFA 
C***DATE  WRITTEN  780814  (YYMMDD) 

C***REVISION  DATE  820801  (YYMMDD) 

C***CATEGORY  NO .  D2A1 

C***KEYWORDS  FACTOR, LINEAR  ALGEBRA , LINPACK , MATRIX 
C***AUTH0R  MOLER,  C.  B.,  (U.  of  NEW  MEXICO) 

C***PURPOSE  Factors  a  real  matrix  by  Gaussian  elimination. 

C***DESCRIPTION 

C 

C  SGEFA  factors  a  real  matrix  by  Gaussian  elimination. 

C 

C  SGEFA  is  usually  called  by  SGECO,  but  it  can  be  called 

C  directly  with  a  saving  in  time  if  RCOND  is  not  needed. 

C  (Time  for  SGECO)  -  (1  +  9/N)*(Time  for  SGEFA)  . 

C  LINPACK.  This  version  dated  08/14/78  . 

C  Cleve  Moler,  University  of  New  Mexico,  Argonne  National  Lab. 

C 

C  Subroutines  and  Functions 

C 

C  BIAS  SAXPY.SSCAL.ISAMAX 

C***REFERENCES  DONGARRA  J  .  J  .  ,  BUNCH  J . R . ,  MOLER  C . B . ,  STEWART  G . W . , 
C  *LINPACK  USERS  GUIDE*,  SIAM,  1979. 

C***R0UT1NES  CALLED  ISAMAX,SAXPY,SSCAL 
C***END  PROLOGUE  SGEFA 

INTEGER  LDA,N,IPVT(1) ,INFO 
REAL  A(LDA,1) 

C 

REAL  T 

INTEGER  ISAMAX,J,K,KP1,L,NM1 
C 

C  GAUSSIAN  ELIMINATION  WITH  PARTIAL  PIVOTING 
C 

C***FIRST  EXECUTABLE  STATEMENT  SGEFA 
INFO  -  0 
NMl  -  N  -  1 

IF  (NMl  .LT.  1)  GO  TO  70 
DO  60  K  -  1,  NMl 
KPl  -  K  +  1 
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C  FIND  L  -  PIVOT  INDEX 

C 

L  -  ISAMAX(N-K+1,A(K,K) ,1)  +  K  -  1 
IPVT(K)  -  L 
C 

C  ZERO  PIVOT  IMPLIES  THIS  COLUMN  ALREADY  TRIANGULARIZED 

C 

IF  (A(L,K)  .EQ.  O.OEO)  GO  TO  40 
C 

C  INTERCHANGE  IF  NECESSARY 

C 

IF  (L  .EQ.  K)  GO  TO  10 
T  -  A(L,K) 

A(L.K)  -  A(K,K) 

A(K,K)  -  T 
10  CONTINUE 

C 

C  COMPUTE  MULTIPLIERS 

C 

T  -  -1.0E0/A(K.K) 

CALL  SSCAL(N-K,T,A(K+1,K) ,1) 

C 

C  ROW  ELIMINATION  WITH  COLUMN  INDEXING 

C 

DO  30  j  *•  xri,  N 
T  -  A(L,J) 

IF  (L  .EQ.  K)  GO  TO  20 
A(L.J)  -  A(K,J) 

A(K,J)  -  T 
20  CONTINUE 

CALL  SAXPY(N-K,T,A(K+1.K) .l.A(K+l,J) ,1) 

30  CONTINUE 

GO  TO  50 
40  CONTINUE 

INFO  -  K 
50  CONTINUE 

60  CONTINUE 
70  CONTINUE 
IPVT(N)  -  N 

IF  (A(N,N)  .EQ.  O.OEO)  INFO  -  N 

RETURN 

END 

SUBROUTINE  SGESL( A ,  IDA , N , IPVT , B , JOB) 

C***BEGIN  PROLOGUE  SGESL 
C***DATE  WRITTEN  780814  (YYMMDD) 

C***REV1SI0N  DATE  820801  (YYMMDD) 

C***CATEGORY  NO .  D2A1 

C***KEYWORDS  LINEAR  ALGEBRA , LINPACK , MATRIX , SOLVE 
C***AUTHOR  MOLER,  C.  B. ,  (U.  OF  NEW  MEXICO) 

C***PURPOSE  Solves  the  real  system  A*X-B  or  TRANS(A)*X-B 
C  using  the  factors  of  SGECO  or  SGEFA 

C***DESCRIPTION 
C 

C  SGESL  solves  the  real  system 
C  A  *  X  -  B  or  TRANS (A)  *  X  -  B 
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C  using  the  factors  computed  by  SGECO  or  SGEFA. 

C 

C***REFERENCES  DONGARRA  J.J..  BUNCH  J.R.,  HOLER  C.B.,  STEWART  G.W., 
C  *LINPACK  USERS  GUIDE*.  SIAM,  1979. 

c***routines  called  SAXPY.SDOT 
C***END  PROLOGUE  SGESL 

integer  lda,n.ipvt(1) .job 

REAL  A(LDA,1) ,B(1) 

C 

REAL  SDOT.T 
INTEGER  K.KB.L.NMl 

C***FIRST  EXECUTABLE  STATEMENT  SGESL 
NMl  -  N  -  1 

IF  (JOB  .NE.  0)  GO  TO  50 
C 

C  JOB  -  0  ,  SOLVE  A  *  X  -  B 

C  FIRST  SOLVE  L*Y  -  B 

C 

IF  (NMl  .LT.  1)  GO  TO  30 
DO  20  K  -  1.  NMl 
L  -  IPVT(K) 

T  -  B(L) 

IF  (L  .EQ.  K)  GO  TO  10 
B(L)  -  B(K) 

B(K)  -  T 

10  CONTINUE 

CALL  SAXPY(N-K.T,A(K+1,K),1,B(K+1\,1) 

20  CONTINUE 

30  CONTINUE 

C 

C  NOW  SOLVE  U*X  -  Y 

C 

DO  40  KB  -  1,  N 
K  -  N  +  1  -  KB 
B(K)  -  B(K)/A(K.K) 

T  -  -B(K) 

CALL  SAXPY(K-1,T,A(1.K).1.B(1),1) 

40  CONTINUE 

GO  TO  100  ^ 

50  CONTINUE 
C 

C  JOB  -  NONZERO,  SOLVE  TRANS (A)  *  X  -  B 

C  FIRST  SOLVE  TRANS (U)*Y  -  B 

C 

DO  60  K  -  1,  N 

T  -  SDOT(K-l,A(l,K) ,1,B(1)  ,1) 

B(K)  -  (B(K)  -  T)/A(K,K) 

60  CONTINUE 

C 

C  NOW  SOLVE  TRANS (L)*X  -  Y 

C 

IF  (NMl  .LT.  1)  GO  TO  vO 
DO  80  KB  -  1,  NMl 
K  -  N  -  KB 

B(K)  -  B(K)  +  SDOT(N-K,A(K+l,K) ,1,B(K+1) .1) 

L  -  IPVT(K) 
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IF  (L  .EQ.  K)  GO  TO  70 
T  -  B(L) 

B(L)  -  B(K) 

B(K)  -  T 

70  CONTINUE 

80  CONTINUE 

90  CONTINUE 

100  CONTINUE 
RETURN 
END 

REAL  FUNCTION  SNRM2  (  N,  SX,  INCX) 

INTEGER  NEXT 

REAL  SX(1),  CUTLO,  CUTHI ,  HITEST,  SUM.  XMAX,  ZERO,  ONE 
DATA  ZERO,  ONE  /O.OEO,  l.OEO/ 

C 

C  EUCLIDEAN  NORM  OF  THE  N-VECTOR  STORED  IN  SX()  WITH  STORAGE 
C  INCREMENT  INCX  . 

C  IF  N  .LE.  0  RETURN  WITH  RESULT  -  0. 

C  IF  N  .GE.  1  THEN  INCX  MUST  BE  .GE.  1 

C 

C  C.L. LAWSON,  1978  JAN  08 

C 

C  FOUR  PHASE  METHOD  USING  TWO  BUILT-IN  CONSTANTS  THAT  ARE 
C  HOPEFULLY  APPLICABLE  TO  ALL  MACHINES. 

C  CUTLO  -  MAXIMUM  OF  SQRT(U/EPS)  OVER  ALL  KNOWN  MACHINES 

C  CUTHI  -  MINIMUM  OF  SQRT(V)  OVER  ALL  KNOWN  MACHINES 

C  WHERE 

C  EPS  -  SMALLEST  NO.  SUCH  THAT  EPS  +  1.  .GT.  1. 

C  U  -  SMALLEST  POSITIVE  NO.  (UNDERFLOW  LIMIT) 

C  V  -  LARGEST  NO.  (OVERFLOW  LIMIT) 

C 

DATA  CUTLO,  CUTHI  /  4.441E-16,  1.304E19  / 

C 

IF(N  .GT.  0)  GO  TO  10 
SNRM2  -  ZERO 
GO  TO  300 
C 

10  ASSIGN  30  TO  NEXT 
SUM  -  ZERO 
NN  -  N  *  INCX 

C  BEGIN  MAIN  LOOP 

I  -  1 

20  GO  TO  NEXT, (30,  50,  70,  110) 

30  1F(  ABS(SX(I))  .GT.  CUTLO)  GO  TO  85 
ASSIGN  50  TO  NEXT 
XMAX  -  ZERO 
C 

C  PHASE  1.  SUM  IS  ZERO 

C 

50  1F(  SX(I)  .EQ.  ZERO)  GO  TO  200 

IF(  ABS(SX(I))  .GT.  CUTLO)  GO  TO  85 
C 

C  PREPARE  FOR  PHASE  2. 

ASSIGN  70  TO  NEXT 
GO  TO  105 
C 
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PREPARE  FOR  PHASE  4. 

100  I  -  J 

ASSIGN  110  TO  NEXT 
SUM  -  (SUM  /  SX(I))  /  SX(I) 

105  XMAX  -  ABS(SX(I)) 

GO  TO  115 

PHASE  2.  SUM  IS  SMALL. 

SCALE  TO  AVOID  DESTRUCTIVE  UNDERFLOW. 

70  IF(  ABS(SX(I))  .GT.  CUTLO  )  GO  TO  75 

COMMON  CODE  FOR  PHASES  2  AND  4. 

IN  PHASE  4  SUM  IS  LARGE.  SCALE  TO  AVOID  OVERFLOW. 

110  IF(  ABS(SX(I))  .LE.  XMAX  )  GO  TO  115 

SUM  -  ONE  +  SUM  *  (XMAX  /  SX(I))**2 
XMAX  -  ABS(SX(I)) 

GO  TO  200 
C 

115  SUM  -  SUM  +  (SX(I)/XMAX)**2 
GO  TO  200 
C 
C 

C  PREPARE  FOR  PHASE  3. 

C 

75  SUM  -  (SUM  *  XMAX)  *  XMAX 
C 
C 

C  FOR  REAL  OR  D.P.  SET  HITEST  -  CUTHI/N 

C  FOR  COMPLEX  SET  HITEST  -  CUTHI/(2*N) 

C 

85  HITEST  -  CUTHI/FLOAT(  N  ) 

C 

C  PHASE  3.  SUM  IS  MID-RANGE.  NO  SCALING. 

C 

DO  95  J  -I.NN.INCX 
IF(ABS(SX(J))  .GE.  HITEST)  GO  TO  100 
95  SUM  -  SUM  +  SX(J)**2 
SNRM2  -  SQRT(  SUM  ) 

GO  TO  300 
C 

200  CONTINUE 

I  -  I  +  INCX 

IF  (  I  .LE.  NN  )  GO  TO  20 
C 

C  END  OF  MAIN  LOOP. 

C 

C  COMPUTE  SQUARE  ROOT  AND  ADJUST  FOR  SCALING. 

C 

SNRM2  -  XMAX  *  SQRT(SUM) 

300  CONTINUE 
RETURN 
END 

SUBROUTINE  SSCAL(N,SA,SX,INCX) 
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REPLACE  SINGLE  PRECISION  SX  BY  SINGLE  PRECISION  SA*SX. 

FOR  I  -  0  TO  N-1,  REPLACE  SX(1+I*INCX)  WITH  SA  *  SX(1+I*INCX) 

REAL  SA,SX(1) 

IF(N.LE.O)RETURN 
IF(INCX.EQ.l)GOTO  20 

CODE  FOR  INCREMENTS  NOT  EQUAL  TO  1. 

NS  -  N*INCX 

DO  10  I  -  l.NS.INCX 
SX(I)  -  SA*SX(I) 

10  CONTINUE 
RETURN 
C 

C  CODE  FOR  INCREMENTS  EQUAL  TO  1. 

C 

C 

C  CLEAN-UP  LOOP  SO  REMAINING  VECTOR  LENGTH  IS  A  MULTIPLE  OF  5. 

C 

20  M  -  MOD(N,5) 

IF(  M  .EQ.  0  )  GO  TO  40 
DO  30  1  -  l.M 
SX(I)  -  SA*SX(I) 

30  CONTINUE 

IF(  N  .LT.  5  )  RETURN 
40  MPl  -  M  +  1 

DO  50  I  -  MPl.N.S 
SX(I)  -  SA*SX<I) 

SX(I  +  1)  -  SA*SX(I  +  1) 

SX(I  +  2)  -  SA*SX(I  +  2) 

SX(I  +  3)  -  SA*SX(I  +  3) 

SX(I  +  4)  -  SA*SX(I  +  4) 

50  CONTINUE 
RETURN 
END 

SUBROUTINE  XERABT(MESSG,NMESSG) 

C***BEGIN  PROLOGUE  XERABT 
C***DATE  WRITTEN  790801  (YYMMDD) 

C***REVISION  DATE  820801  (YYMMDD) 

C***CATEGORY  NO.  R3C 
C***KEYWORDS  ERROR, XERROR  PACKAGE 
C***AUTHOR  JONES,  R.  E. ,  (SNLA) 

C***PURPOSE  Aborts  program  execution  and  prints  error  message. 
C***DESCRIPTION 
C  Abstract 

C  ***Note***  machine  dependent  routine 

C  XERABT  aborts  the  execution  of  the  program. 

C  The  error  message  causing  the  abort  is  given  in  the  calling 

C  sequence,  in  case  one  needs  it  for  printing  on  a  dayfile, 

C  for  example . 

C 

C  Description  of  Parameters 

C  MESSG  and  NMESSG  are  as  in  XERROR,  except  that  NMESSG  may 

C  be  zero,  in  which  case  no  message  is  being  supplied. 
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C  Written  by  Ron  Jones,  with  SLATEC  Conunon  Math  Library  Subcommittee 
C  Latest  revision  -  19  MAR  1980 

C***REFERENCES  JONES  R.E. ,  KAHANER  D.K. ,  "XERROR,  THE  SLATEC  ERROR- 
C  HANDLING  PACKAGE",  SAND82-0800,  SANDIA  LABORATORIES, 

C  1982. 

C***ROUTINES  CALLED  (NONE) 

C***END  PROLOGUE  XERABT 
CHARACTER*(*)  MESSG 

C***FIRST  EXECUTABLE  STATEMENT  XERABT 
STOP 
END 

SUBROUTINE  XERCLR 
C***BEGIN  PROLOGUE  XERCLR 
C***DATE  written  790801  (YYMMDD) 

C***REVISION  DATE  820801  (YYMMDD) 

C***CATEGORY  NO .  R3C 
C***KEYWORDS  ERROR, XERROR  PACKAGE 
C*** author  JONES,  R.  E. ,  (SNLA) 

C***PURPOSE  Resets  current  error  number  to  zero. 

C***DESCRIPTION 
C  Abstract 

C  This  routine  simply  resets  the  current  error  number  to  zero. 

C  This  may  be  necessary  to  do  in  order  to  determine  that 

C  a  certain  error  has  occurred  again  since  the  last  time 

C  NUMXER  was  referenced. 

C 

C  Written  by  Ron  Jones,  with  SLATEC  Common  Math  Library  Subcommittee 
C  Latest  revision  ---  7  June  1978 

C***REFERENCES  JONES  R.E.,  KAHANER  D.K. ,  "XERROR,  THE  SLATEC  ERROR- 
C  HANDLING  PACKAGE",  SAND82-0800,  SANDIA  LABORATORIES, 

C  1982. 

C***ROUTINES  CALLED  J4SAVE 
C***END  PROLOGUE  XERCLR 
C***FIRST  EXECUTABLE  STATEMENT  XERCLR 
JUNK  -  J4SAVE(1,0, .TRUE.) 

RETURN 

END 

SUBROUTINE  XERCTL(MESSG1 ,NMESSG , NERR , LEVEL , KONTRL) 

C***BEGIN  PROLOGUE  XERCTL 
C***DATE  WRITTEN  790801  (YYMMDD) 

C***REVISlf  J  DATE  820801  (YYMMDD) 

C***CATEGORY  NO .  R3C 
C***KEYW0RDS  ERROR, XERROR  PACKAGE 
C***AUTHOR  JONES,  R.  E. ,  (SNLA) 

C***PURPOSE  Allows  user  control  over  handling  of  individual  errors. 
C***DESCRIPTION 
C  Abstract 

C  Allows  user  control  over  handling  of  individual  errors. 

C  Just  after  each  message  is  recorded,  but  before  it  is 

C  processed  any  further  (i.e.,  before  it  is  printed  or 

C  a  decision  to  abort  is  made),  a  call  is  made  to  XERCTL. 

C  If  the  user  has  provided  his  own  version  of  XERCTL,  he 

C  can  then  override  the  value  of  KONTROL  used  in  processing 

C  this  message  by  redefining  its  value. 

C  KONTRL  may  be  set  to  any  value  from  -2  to  2. 
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Z  The  meanings  for  KONTRL  are  the  same  as  in  XSETF,  except 

C  that  the  value  of  KONTRL  changes  only  for  this  message. 

C  If  KONTRL  is  set  to  a  value  outside  the  range  from  -2  to  2, 

C  it  will  be  moved  back  into  that  range. 

C 

C***REFERENCES  JONES  R.E.,  KAHANER  D.K. .  "XERROR,  THE  SLATEC  ERROR- 
C  HANDLING  PACKAGE",  SAND82-0800,  SANDIA  LABORATORIES, 

C  1982. 

C***ROUTINES  CALLED  (NONE) 

C***END  PROLOGUE  XERCTL 
CHARACTER*20  MESSGl 

C***FIRST  EXECUTABLE  STATEMENT  XERCTL 
RETURN 
END 

SUBROUTINE  XERDMP 
C***BEGIN  PROLOGUE  XERDMP 
C***DATE  WRITTEN  790801  (YYMMDD) 

C***REVISI0N  DATE  820801  (YYMMDD) 

C***CATEGORY  NO .  R3C 
C***KEYWORDS  ERROR, XERROR  PACKAGE 
C***AUTH0R  JONES,  R.  E. ,  (SNLA) 

C***PURP0SE  Prints  the  error  tables  and  then  clears  them. 
C***DESCRIPT10N 
C  Abstract 

C  XERDMP  prints  the  error  tables,  then  clears  them. 

C 

C  Written  by  Ron  Jones,  with  SLATEC  Common  Math  Library  Subcommittee 
C  Latest  revision  ---  7  June  1978 

C***REFERENCES  JONES  R.E.,  KAHANER  D.K. ,  "XERROR,  THE  SLATEC  ERROR- 
C  HANDLING  PACKAGE",  SAND82-0800,  SANDIA  LABORATORIES, 

C  1982. 

C***ROUTINES  CALLED  XERSAV 
C***END  PROLOGUE  XERDMP 
C***FIRST  EXECUTABLE  STATEMENT  XERDMP 
CALL  XERSAV( '  ',0,0,0, KOUNT) 

RETURN 

END 

SUBROUTINE  XERMAX(MAX) 

C***BEGIN  PROLOGUE  XERMAX 
C***DATE  WRITTEN  790801  (YYMMDD) 

C***REVISION  DATE  820801  (YYMMDD) 

C***CATEGORY  NO .  R3C 
C***KEYWORDS  ERROR, XERROR  PACKAGE 
C***AUTH0R  JONES,  R.  E.,  (SNLA) 

C***PURPOSE  Sets  maximum  number  of  times  any  error  message  is  to  be 
C  printed. 

C***DESCRIPTION 
C  Abstract 

C  XERMAX  sets  the  maximum  number  of  times  any  message 

C  is  to  be  printed.  That  is,  non-fatal  messages  are 

C  not  to  be  printed  after  they  have  occured  MAX  times. 

C  Such  non-fatal  messages  may  be  printed  less  than 

C  MAX  times  even  If  they  occur  MAX  times,  if  error 

C  suppression  mode  (KONTRL-0)  is  ever  in  effect. 

C 

C  Written  by  Ron  Jones,  with  SLATEC  Common  Math  Library  Subcommittee 
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C  Latest  revision  -  7  June  1978 

C***REFERENCES  JONES  R.E.,  KAHANER  D.K.,  "XERROR,  THE  SLATEC  ERROR- 
C  HANDLING  PACKAGE",  SAND82-0800,  SANDIA  LABORATORIES, 

C  1982. 

C***ROUTINES  CALLED  J4SAVE 
C***END  PROLOGUE  XERMAX 
C***FIRST  EXECUTABLE  STATEMENT  XERMAX 
JUNK  -  J4SAVE(4,MAX, .TRUE.) 

RETURN 

END 

SUBROUTINE  XERPRT(MESSG ,NMESSG) 

C***BEGIN  PROLOGUE  XERPRT 
C***DATE  WRITTEN  790801  (YYMMDD) 

C***REVISI0N  date  820801  (YYMMDD) 

C***CATEGORY  NO .  Z 
C***KEYWORDS  ERROR, XERROR  PACKAGE 
C***AUTHOR  JONES,  R.  E.,  (SNLA) 

C***PURPOSE  Prints  error  messages. 

C***DESCRIPTION 
C  Abstract 

C  Print  the  Hollerith  message  in  MESSG,  of  length  NMESSG, 

C  on  each  file  indicated  by  XGETUA. 

C  Latest  revision  19  MAR  1980 

C***REFERENCES  JONES  R.E.,  KAHANER  D.K. ,  "XERROR,  THE  SLATEC  ERROR- 
C  HANDLING  PACKAGE",  SAND82-0800,  SANDIA  LABORATORIES, 

C  1982. 

C***ROUTINES  CALLED  IlMACH , S88FMT , XGETUA 
C***END  PROLOGUE  XERPRT 
INTEGER  LUN(5) 

CHARACTER* (*)  MESSC 

C  OBTAIN  UNIT  NUMBERS  AND  WRITE  LINE  TO  EACH  UNIT 
C***FIRST  EXECUTABLE  STATEMENT  XERPRT 
CALL  XGETUA(LUN,NUNIT) 

LENMES  -  LEN (MESSG) 

DO  20  KUNIT-1 , NUNIT 
lUNIT  -  LUN(KUNIT) 

IF  (lUNIT.EQ.O)  lUNIT  -  I1MACH(4) 

DO  10  ICHAR-1, LENMES, 72 

LAST  -  MIN0(ICHAR+7l  ,  LENMES) 

WRITE  (IUNIT,'(1X,A)')  MESSG (ICHAR: LAST) 

10  CONTINUE 
20  CONTINUE 
RETURN 
END 

SUBROUTINE  XERROR (MESSG , NMESSG , NERR , LEVEL) 

C***BEGIN  PROLOGUE  XERROR 
C***DATE  WRITTEN  790801  (YYMMDD) 

C***REVISION  DATE  820801  (YYMMDD) 

C***CATEGORY  NO .  R3C 
C***KEYWORDS  ERROR, XERROR  PACKAGE 
C***AUTH0R  JONES,  R.  E.,  (SNLA) 

C***PURPOSE  Processes  an  error  (diagnostic)  message. 

C***DESCRIPTI0N 
C  Abstract 

C  XERROR  processes  a  diagnostic  message,  in  a  manner 

C  determined  by  the  value  of  LEVEL  and  the  current  value 
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C  of  the  library  error  control  flag,  KONTRL. 

C  (See  subroutine  XSETF  for  details.) 

C 

C  Latest  revision  ---  19  MAR  1980 

C  Written  by  Ron  Jones,  with  SLATEC  Common  Math  Library  Subcommittee 
C***REFERENCES  JONES  R.E.,  KAHANER  D.K.,  "XERROR,  THE  SLATEC  ERROR- 
C  HANDLING  PACKAGE",  SAND82-0800,  SANDIA  LABORATORIES, 

C  1982. 

C***ROUTINES  CALLED  XERRWV 
C***END  PROLOGUE  XERROR 
CHARACTER* (*)  MESSG 

C***FIRST  EXECUTABLE  STATEMENT  XERROR 

CALL  XERRWV(MESSG,NMESSG,NERR,LEVEL,0.0,0,0,0. ,0.) 

RETURN 

END 

SUBROUTINE  XERRWV(MESSG , NMESSG , NERR , LEVEL , NI , I 1 , 12 , NR , R1 , R2 ) 
C***BEGIN  PROLOGUE  XERRWV 
C***DATE  WRITTEN  800319  (YYMMDD) 

C***REVISION  DATE  820801  (YYMMDD) 

C***CATEGORY  NO .  R3C 
C***KEYWORDS  ERROR, XERROR  PACKAGE 
C***AUTH0R  JONES,  R.  E. ,  (SNLA) 

C***PURPOSE  Processes  error  message  allowing  2  integer  and  two  real 
C  values  to  be  included  in  the  message . 

C***DESCRIPTION 
C  Abstract 

C  XERRWV  processes  a  diagnostic  message,  in  a  manner 

C  determined  by  the  value  of  LEVEL  and  the  current  value 

C  of  the  library  error  control  flag,  KONTRL. 

C  (See  subroutine  XSETF  for  details.) 

C  In  addition,  up  to  two  integer  values  and  two  real 

C  values  may  be  printed  along  with  the  message . 

C 

C  Latest  revision  ---  19  MAR  1980 

C  Written  by  Ron  Jones,  with  SLATEC  Common  Math  Library  Subcommittee 
C***REFERENCES  JONES  R.E. ,  KAHANER  D.K.,  "XERROR,  THE  SLATEC  ERROR- 
C  HANDLING  PACKAGE",  SAND82-0800,  SANDIA  LABORATORIES, 

C  1982. 

C***ROUTINES  CALLED  FDUMP , I IMACH , J4SAVE , XERABT , XERCTL , XERPRT , XERSAV , 

C  XGETUA 

C***END  PROLOGUE  XERRWV 
CHARACTER* (*)  MESSG 
CKARACTER*20  LFIRST 
CHARACTEP+37  FORM 
DIMENSION  LUN(5) 

C  GET  FLAGS 

C***FIRST  EXECUTABLE  STATEMENT  XERRWV 
LKNTRL  -  J4SAVE (2,0, .FALSE. ) 

MAXMES  -  J4SAVE(4,0, .FALSE.) 

C  CHECK  FOR  VALID  INPUT 

IF  ( (NMESSG. GT.O) .AND. (NERR. NE.O) .AND. 

1  (LEVEL. GE. (-1)) .AND. (LEVEL. LE. 2))  GO  TO  10 

IF  (LKNTRL. GT.O)  CALL  XERPRT (' FATAL  ERROR  IN. . . ' ,17) 

CALL  XERPRT ('XERROR  --  INVALID  INPUT ',23) 

IF  (LKNTRL. GT.O)  CALL  FDUMP 

IF  (LKNTRL. GT.O)  CALL  XERPRT ('JOB  ABORT  DUE  TO  FATAL  ERROR.', 
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29) 

IF  (LKNTRL.GT.O)  CALLXERSAV('  ' , 0 , 0 , 0 .KDUMMY) 

CALL  XERABT('XERROR  --  INVALID  INPUT '.23) 

RETURN 
10  CONTINUE 
C  RECORD  MESSAGE 

JUNK  -  J4SAVE(1.NERR, .TRUE.) 

CALL  XERSAV(MESSG , NMESSG , NERR . LEVEL, KOUNT) 

C  LET  USER  OVERRIDE 

LFIRST  -  MESSG 
LMESSG  -  NMESSG 
LERR  -  NERR 
LLEVEL  -  LEVEL 

CALL  XERCTL( LFIRST , LMESSG , LERR , LLEVEL, LKNTRL) 

C  RESET  TO  ORIGINAL  VALUES 

LMESSG  -  NMESSG 
LERR  -  NERR 
LLEVEL  -  LEVEL 

LKNTRL  -  MAX0(-2,MIN0(2,LKNTRL)) 

MKNTRL  -  lABS (LKNTRL) 

C  DECIDE  WHETHER  TO  PRINT  MESSAGE 

IF  ((LLEVEL. LT. 2) .AND. (LKNTRL. EQ.O))  GO  TO  100 
IF  (( (LLEVEL. EQ. (-1)) .AND. (KOUNT .GT .MIN0(1 .MAXMES) ) ) 
l.OR. ((LLEVEL. EQ.O)  . AND . (KOUNT . GT . MAXMES) ) 

2.0R. ((LLEVEL.EQ.l)  .AND. (KOUNT. GT. MAXMES) . AND . (MKNTRL. EQ. 1) ) 

3. OR. ((LLEVEL. EQ. 2)  .AND. (KOUNT. GT.MAX0(1,MAXMES))))  GO  TO  100 

IF  (LKNTRL. LE.O)  GO  TO  20 
CALLXERPRTC  ',!) 

C  INTRODUCTION 

IF  (LLEVEL. EQ. (-1))  CALL  XERPRT 

1( 'WARNING  MESSAGE. . .THIS  MESSAGE  WILL  ONLY  BE  PRINTED  ONCE. ',57) 

IF  (LLEVEL. EQ.O)  CALL  XERPRT ( 'WARNING  IN... ',13) 

IF  (LLEVEL.EQ.l)  CALL  XERPRT 
1  (' RECOVERABLE  ERROR  IN. . . ' ,23) 

IF  (LLEVEL. EQ. 2)  CALL  XERPRT (' FATAL  ERROR  IN. . . ' ,17) 

20  CO’‘'TIN'JF 

C  MESSAGE 

CALL  XERPRT(MESSG, LMESSG) 

CALL  XGETUA(LUN,NUNIT) 

ISIZEI  -  LOG10(FLOAT(I1MACH(9)))  +  1.0 
ISIZEF  -  LOG10(FLOAT(I1MACH(10))**I1MACH(11))  +1.0 
DO  50  KUNIT-1 , NUNIT 
lUNIT  -  LUN(KUNIT) 

IF  (lUNIT.EQ.O)  lUNIT  -  I1MACH(4) 

DO  22  I-1,MIN(NI,2) 

WRITE  (FORM, 21)  I, ISIZEI 

21  FORMAT  (' (11X,21HIN  ABOVE  MESSAGE,  I ' , II , ' - , I ',12 , ' )  ') 

IF  (I.EQ.l)  WRITE  (IUNIT,FORM)  II 

IF  (I.EQ.2)  WRITE  (lUNIT.FORM)  12 

22  CONTINUE 

DO  24  I-1,MIN(NR,2) 

WRITE  (FORM, 23)  I , ISIZEF+10 , ISIZEF 

23  FORMAT  (' (IIX, 21HIN  ABOVE  MESSAGE,  R',I1,'-,E', 

1  12.' .' ,12,')') 

IF  (I.EQ.l)  WRITE  (lUNIT.FORM)  R1 
IF  (I.EQ.2)  WRITE  (lUNIT.FORM)  R2 
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24  CONTINUE 

IF  (LKNTRL.LE.O)  GO  TO  40 
C  ERROR  NUMBER 

WRITE  (IUNIT,30)  LERR 

30  FORMAT  (15H  ERROR  NUMBER  -.110) 

40  CONTINUE 

50  CONTINUE 
C  TRACE -BACK 

IF  (LKNTRL.GT.O)  CALL  FDUMP 
100  CONTINUE 
I FATAL  -  0 

IF  ((LLEVEL.EQ.2) .OR. ((LLEVEL.EQ.l) .AND. (MKNTRL . EQ . 2 ) ) ) 

II FATAL  -  1 

C  QUIT  HERE  IF  MESSAGE  IS  NOT  FATAL 

IF  (IFATAL.LE.O)  RETURN 

IF  ((LKNTRL.LE.O) .OR. (KOUNT.GT.MAX0(l,MAXMES)))  GO  TO  120 
C  PRINT  REASON  FOR  ABORT 

IF  (LLEVEL.EQ.l)  CALL  XERPRT 
1  ('JOB  ABORT  DUE  TO  UNRECOVERED  ERROR. ',35) 

IF  (LLEVEL.EQ.2)  CALL  XERPRT 
1  ('JOB  ABORT  DUE  TO  FATAL  ERROR. ',29) 

C  PRINT  ERROR  SUMMARY 

CALL  XERSAV('  ' , - 1 . 0 , 0 , KDUMMY) 

120  CONTINUE 
C  ABORT 

IF  ((LLEVEL.EQ.2) .AND. (K0UNT.GT.MAX0(1,MAXMES)))  LMESSG  -  0 
CALL  XERABT(MESSG, LMESSG) 

RETURN 

END 

SUBROUTINE  XERSAV(MESSG,NMESSG,NERR, LEVEL, ICOUNT) 

C***BEGIN  PROLOGUE  XERSAV 
C***DATE  WRITTEN  800319  (YYMMDD) 

C***REVISION  DATE  820801  (YYMMDD) 

C***CATEGORY  NO.  Z 
C***KEYWORDS  ERROR, XERROR  PACKAGE 
C*** AUTHOR  JONES,  R.  E. ,  (SNLA) 

C***PURPOSE  Records  that  an  error  occurred. 

C***DESCRIPTION 
C  Abstract 

C  Record  that  this  error  occurred. 

C 

C  Written  by  Ron  Jones,  with  SLATEC  Conunon  Math  Library  Subcommittee 
C  Latest  revision  —  19  Mar  1980 

C***REFERENCES  JONES  R.E. ,  KAHANER  D.K. ,  "XERROR,  THE  SLATEC  ERROR- 
C  HANDLING  PACKAGE",  SAND82-0800,  SANDIA  LABORATORIES, 

C  1982. 

C***R0UTINES  called  IlMACH , S88FMT , XGETUA 
C***END  PROLOGUE  XERSAV 
INTEGER  LUN(5) 

CHARACTER* (*)  MESSG 

CHARACTER*20  MESTAB(IO) ,MES 

DIMENSION  NERTAB(IO) ,LEVTAB(10) ,KOUNT(10) 

SAVE  MESTAB,NERTAB,LEVTAB,KOUNT,KOUNTX 
C  NEXT  TWO  DATA  STATEMENTS  ARE  NECESSARY  TO  PROVIDE  A  BLANK 
C  ERROR  TABLE  INITIALLY 

DATA  KOUNT(l) ,KOUNT(2) ,KOUNT(3  K0UNT(4) ,KOUNT(5) , 
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1  K0UNT(6) ,K0UNT(7) ,K0UNT(8) ,K0UNT(9) ,KOUNT(10) 

2  /O, 0,0, 0,0, 0,0, 0,0,0/ 

DATA  KOUNTX/0/ 

C***FIRST  EXECUTABLE  STATEMENT  XERSAV 
IF  (NMESSG.GT.O)  GO  TO  80 
C  DUMP  THE  TABLE 

IF  (KOUNT(l) .EQ.O)  RETURN 
C  PRINT  TO  EACH  UNIT 

CALL  XGETUA(LUN,NUNIT) 

DO  60  KUNIT-1,NUNIT 
lUNIT  -  LUN(KUNIT) 

IF  (lUNIT.EQ.O)  lUNIT  -  I1MACH(4) 

C  PRINT  TABLE  HEADER 

WRITE  (lUNIT.lO) 

10  FORMAT  (32HO  ERROR  MESSAGE  SUMMARY/ 

1  51H  MESSAGE  START  NERR  LEVEL  COUNT) 

C  PRINT  BODY  OF  TABLE 

DO  20  1-1,10 

IF  (KOUNT(I) .EQ.O)  GO  TO  30 

WRITE  (IUNIT,15)  MESTAB ( I ) , NERTAB ( I ) , LEVTAB ( I ) , KOUNT ( I ) 
15  FORMAT  (1X,A20,3I10) 

20  CONTINUE 

30  CONTINUE 

C  PRINT  NUMBER  OF  OTHER  ERRORS 

IF  (KOUNTX.NE.O)  WRITE  (IUNIT,40)  KOUNTX 
40  FORMAT  (41HOOTHER  ERRORS  NOT  INDIVIDUALLY  TABULATED- , 110) 

WRITE  (IUNIT,50) 

50  FORMAT  (IX) 

60  CONTINUE 

IF  (NMESSG.lt. 0)  RETURN 
C  CLEAR  THE  ERROR  TABLES 

DO  70  T-1,10 
70  KOUNT(I)  -  0 

KOUNTX  -  0 
RETURN 
80  CONTINUE 

PROCESS  A  MESSAGE. . . 

SEARCH  FOR  THIS  MESSG,  OR  ELSE  AN  EMPTY  SLOT  FOR  THIS  MESSG, 

C  OR  ELSE  DETERMINE  THAT  THE  ERROR  TABLE  IS  FULL. 

MES  -  MESSG 
DO  90  1-1,10 
II  -  I 

IF  (KOUNT(I) .EQ.O)  GO  TO  110 
IF  (MES.NE.MESTAB(I))  GO  TO  90 
IF  (NERR.NE.NERTAB(I))  GO  TO  90 
IF  ( LEVEL. NE.LEVTAB(I))  GO  TO  90 
GO  TO  100 
90  CONTINUE 

C  THREE  POSSIBLE  CASES. . . 

C  TABLE  IS  FULL 

KOUNTX  -  KOUNTX+1 
ICOUNT  -  1 
RETURN 

C  MESSAGE  FOUND  IN  TABLE 

100  KOUNT(II)  -  KOUNT(II)  +  1 
ICOUNT  -  KOUNT (II) 
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RETURN 

C  EMPTY  SLOT  FOUND  FOR  NEW  MESSAGE 
110  MESTAB(II)  -  MES 
NERTAB(II)  -  NERR 
LEVTAB(II)  -  LEVEL 
KOUNT(II)  -  1 
I COUNT  -  1 
RETURN 

END 

SUBROUTINE  XGETF(KONTRL) 

C***BFGTN  PROLOGUE  XGETF 
C***DATE  WRITTEN  790801  (YYMMDD) 

C***REVISION  DATE  820801  (YYMMDD) 

C***CATEGORY  NO .  R3C 
C***KEYWORDS  ERROR, XERROR  PACKAGE 
C***AUTHOR  JONES,  R.  E. ,  (SNLA) 

C***purP0SE  Returns  current  value  of  error  control  flag. 

C***DESCRIPTION 
C  Abstract 

C  XGETF  returns  the  current  value  of  the  error  control  flag 

C  in  KONTRL.  See  subroutine  XSETF  for  flag  value  meanings. 

C  (KONTRL  is  an  output  parameter  only.) 

C 

C  Written  by  Ron  Jones,  with  SLATEC  Common  Math  Library  Subcommittee 
C  Latest  revision  ---  7  June  1978 

C***REFERENCES  JONES  R.E.,  KAHANER  D.K. ,  "XERROR,  THE  SLATEC  ERROR- 
C  HANDLING  PACKAGE",  SAND82-0800,  SANDIA  LABORATORIES, 

C  1982. 

C***ROUTINES  CALLED  J4SAVE 
C***END  PROLOGUE  XGETF 
C***FIRST  EXECUTABLE  STATEMENT  XGETF 
KONTRL  -  J4SAVE( 2,0, .FALSE.) 

RETURN 

END 

SUBROUTINE  XGETUA(IUNITA,N) 

C***BEGIN  PROLOGUE  XGETUA 
C***DATE  written  790801  (YYMMDD) 

C***REVISION  DATE  820801  (YYMMDD) 

C***CATEGORY  NO.  R3C 
C***KEYWORDS  ERROR, XERROR  PACKAGE 
C***AUTH0R  JONES,  R.  E. ,  (SNLA) 

C***PURPOSE  Returns  unit  number (s)  to  which  error  messages  are  being 
C  sent. 

C***DESCRIPTION 
C  Abstract 

C  XGETUA  may  be  called  to  determine  the  unit  number  or  numbers 

C  to  which  error  messages  are  being  sent. 

C  These  unit  numbers  may  have  been  set  by  a  call  to  XSETUN, 

C  or  a  call  to  XSETUA,  or  may  be  a  default  value. 

C 

C  Latest  revision  ---  19  MAR  1980 

C  Written  by  Ron  Jones,  with  SLATEC  Common  Math  Library  Subcommittee 
C***REFERENCES  JONES  R.E.,  KAHANER  D.K. ,  "XERROR,  THE  SLATEC  ERROR- 
C  HANDLING  PACKAGE",  SAND82-0800,  SANDIA  LABORATORIES, 

C  1032. 

C***ROUTINES  CALLED  J4SAVE 


C***END  PROLOGUE  XGETUA 
DIMENSION  IUNITA(5) 

C***FIRST  EXECUTABLE  STATEMENT  XGETUA 
N  -  J4SAVE( 5,0, .FALSE.) 

DO  30  I-1,N 
INDEX  -  1+4 
IF  (I.EQ.l)  INDEX  -  3 
lUNITA(I)  -  J4SAVE(INDEX,0, .FALSE.) 

30  CONTINUE 
RETURN 
END 

SUBROUTINE  XGETUN(IUNIT) 

C***BEGIN  PROLOGUE  XGETUN 
C***DATE  WRITTEN  790801  (YYMMDD) 

C***REVISION  DATE  820801  (YYMMDD) 

C***CATEGORY  NO .  R3C 
C***KEYWORDS  ERROR, XERROR  PACKAGE 
C***AUTHOR  JONES,  R.  E. ,  (SNLA) 

C***PURPOSE  Returns  the  (first)  output  file  to  which  messages  are  being 
C  sent. 

C***DESCRIPTION 
C  Abstract 

C  XGETUN  gets  the  (first)  output  file  to  which  error  messages 

C  are  being  sent.  To  find  out  if  more  than  one  file  is  being 

C  used,  one  must  use  the  XGETUA  routine. 

C 

C  Written  by  Ron  Jones,  with  SLATEC  Common  Math  Library  Subcommittee 
C  Latest  revision  —  23  May  1979 

C***REFERENCES  JONES  R.E.,  KAHANER  D.K. ,  "XERROR,  THE  SLATEC  ERROR - 
C  HANDLING  PACKAGE",  SAND82-0800,  SANDIA  LABORATORIES, 

C  1982. 

C***ROUTINES  CALLED  J4SAVE 
C***END  PROLOGUE  XGETUN 
C***FIRST  EXECUTABLE  STATEMENT  XGETUN 
lUNIT  -  J4SAVE( 3,0, .FALSE.) 

RETURN 

END 

SUBROUTINE  XSETF(KONTRL) 

C***BEGIN  PROLOGUE  XSETF 
C***DATE  WRITTEN  790801  (YYMMDD) 

C***REVISION  DATE  820801  (YYMMDD) 

C***CATEGORY  NO .  R3A 
C***KEYWORDS  ERROR. XERROR  PACKAGE 
C*** author  JONES,  R.  E. ,  (SNLA) 

C***PURPOSE  Sets  the  error  control  flag. 

C***DESCRIPTION 
C  Abstract 

C  XSETF  sets  the  error  control  flag  value  to  KONTRL. 

C  (KONTRL  is  an  input  parameter  only.) 

C  The  following  table  shows  how  each  message  is  treated, 

C  depending  on  the  values  of  KONTRL  and  LEVEL.  (See  XERROR 

C  for  description  of  LEVEL.) 

C 

C  If  KONTRL  is  zero  or  negative,  no  information  other  than  the 

C  message  itself  (including  numeric  values,  if  any)  will  be 

C  printed.  If  KONTRL  is  positive,  introductory  messages. 
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C  trace-backs,  etc.,  will  be  printed  in  addition  to  the  message. 

C 

C  Written  by  Ron  Jones,  with  SLATEC  Common  Math  Library  Subcommittee 
C  Latest  revision  -  19  MAR  1930 

C***REFERENCES  JONES  R.E.,  KAHANER  D.K. ,  "XERROR,  THE  SLATEC  ERROR- 
C  HANDLING  PACKAGE",  SAND82-0800,  SANDIA  LABORATORIES, 

C  1982. 

C***ROUTINES  CALLED  J4SAVE , XERRWV 

C***END  PROLOGUE  XSETF 

C***FIRST  EXECUTABLE  STATEMENT  XSETF 

IF  ((KONTRL.GE. (-2)) .AND. (KONTRL.LE.2))  GO  TO  10 

CALL  XERRWV ( 'XSETF  --  INVALID  VALUE  OF  KONTRL  (II). ',33, 1,2, 

1  1, KONTRL, 0, 0, 0. ,0. ) 

RETURN 

10  JUNK  -  J4SAVE( 2, KONTRL, .TRUE.) 

RETURN 

END 

SUBROUTINE  XSETUA(IUNITA,N) 

C***BEGIN  PROLOGUE  XSETUA 
C***DATE  WRITTEN  790801  (YYMMDD) 

C***REVISION  DATE  820801  (YYMMDD) 

C***CATEGORY  NO.  R3B 
C***KEYW0RDS  error , XERROR  PACKAGE 
C***AUTH0R  JONES.  R.  E.,  (SNLA) 

C***PURP0SE  Sets  up  to  5  unit  numbers  to  which  messages  are  to  be  sent. 
C***DESCRIPTI0N 
C  Abstract 

C  XSETUA  may  be  called  to  declare  a  list  of  up  to  five 

C  logical  units,  each  of  which  is  to  receive  a  copy  of 

C  each  error  message  processed  by  this  package. 

C  The  purpose  of  XSETUA  is  to  allow  simultaneous  printing 

C  of  each  error  message  on,  say,  a  main  output  file, 

C  an  interactive  terminal,  and  other  files  such  as  graphics 

C  communication  files. 

C 

C  Written  by  Ron  Jones,  with  SLATEC  Common  Math  Library  Subcommittee 
C  Latest  revision  —  19  MAR  1980 

C***REFERENCES  JONES  R.E.,  K/J^ANER  D.K.,  "XERROR,  THE  SLATEC  ERROR- 
C  HANDLING  PACKAGE",  SAND82-0800,  SANDIA  LABORATORIES, 

C  1982. 

C***ROUTINES  CALLED  J4SAVE .XERRWV 
C***END  PROLOGUE  XSETUA 
DIMENSION  IUNITA(5) 

C***FIRST  EXECUTABLE  STATEMENT  XSETUA 

IF  ((N.GE.l) .AND. (N.LE.5))  GO  TO  10 

CALL  XERRWV ('XSETUA  --  INVALID  VALUE  OF  N  (II) . ' , 34 , 1 , 2 , 

1  1,N,0,0,0. ,0.) 

RETURN 
10  CONTINUE 
DO  20  I-1,N 
INDEX  -  1+4 
IF  (I.EQ.l)  INDEX  -  3 
JUNK  -  J4SAVE(INDEX,IUNITA(I) , .TRUE.) 

20  CONTINUE 

JUNK  -  J4SAVE(5,N, .TRUE.) 

RETURN 
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END 

SUBROUTINE  XSETUN(IUNIT) 

C***BEGIN  PROLOGUE  XSETUN 
C***DATE  WRITTEN  790801  (YYMMDD) 

C***REVISION  DATE  820801  (YYMMDD) 

C***CATEGORY  NO .  R3B 
C***KEYWORDS  ERROR, XERROR  PACKAGE 
C***AUTHOR  JONES,  R.  E. ,  (SNLA) 

C***PURPOSE  Sets  output  file  to  which  error  messages  are  to  be  sent. 
C***DESCRIPTION 
C  Abstract 

C  XSETUN  sets  the  output  file  to  which  error  messages  are  to 

C  be  sent.  Only  one  file  will  be  used.  See  XSETUA  for 

C  how  to  declare  more  than  one  file . 

C 

C  Written  by  Ron  Jones,  with  SLATEC  Common  Math  Library  Subcommittee 
C  Latest  revision  ---  7  June  1978 

:***REFERENCES  JONES  R.E.,  KAHANER  D.K. ,  "XERROR,  THE  SLATEC  ERROR- 
C  HANDLING  PACKAGE",  SAND82-0800,  SANDIA  LABORATC^'IES , 

C  1982. 

C***ROUTINES  CALLED  J4SAVE 
C***END  PROLOGUE  XSETUN 
C***FIRST  EXECUTABLE  STATEMENT  XSETUN 
JUNK  -  J4SAVE(3,IUNIT, .TRUE. ) 

JUNK  -  J4SAVE(5,1, .TRUE. ) 

RETURN 

END 
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BLANK . 
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No  of 

Copies  Ortznni/aiion 


(LneUis.,  uiiiimiicd)12  Adminisuator 

(I'ntuss.,  limiud)  2  Defense  Technical  Info  Center 

(CiassiHcd)  2  ATTN:  DTIC-DDA 

Cameron  Station 
Alexandria,  VA  22304-6145 


1  HQDA  (SARD-TR) 
WASH  DC  20310-0001 


1  Commander 

US  Army  Materiel  Command 
ATTN:  AMCDRA-ST 
5001  Eisenhower  Avenue 
Alexandria.  VA  22333-0001 

1  Commander 

US  Army  Laboratory  Command 
ATTN:  AMSLC-DL 
Adelphi,  MD  20783-1145 

2  Commander 
Armament  RD&E  Center 
US  Army  AMCCOM 
ATTN:  SMCAR-MSI 
Picatinny  Arsenal,  NJ  07806-5000 

2  Commander 

Armament  RD&E  Center 
US  Army  AMCCOM 
ATTN:  SMCAR-TDC 
Picatinny  Arsenal,  NJ  07806-5000 

1  Director 

Bcnct  Weapons  Laboratory 
Armament  RD&E  Center 
US  Army  AMCCOM 
ATTN:  SMCAR-LCB-TL 
Watcrvlict.  NY  12189-4050 

1  Commander 

US  Army  Armament,  Munitions 
and  Chemical  Command 
ATTN:  SMCAR-ESP-L 
Rock  Island,  IL  61299-5000 

1  Commander 

US  Army  Aviation  Systems  Command 
ATTN:  AMSAV-DACL 
4300  Goodfellow  Blvd. 

St.  Louis,  MO  63120-1798 

1  Director 

US  Army  Aviation  Research 
and  Technology  Activity 
Ames  Research  Center 
Moffett  Field,  CA  94035-1099 


No  of 

Copies  Organisation 

1  Commander 

US  Army  Missile  Command 
ATTN:  AMSMl-RD-CS-R  (DOC) 

Redstone  Arsenal,  AL  35898-5010 

1  Commander 

US  Army  Tank  Automotive  Command 
ATTN:  AMSTA-TSL  (Technical  Library) 
Warren,  MI  48397-5000 

1  Director 

US  Army  TRADOC  Analysis  Command 
ATTN:  ATAA-SL 

White  Sands  Missile  Range,  NM  88002-5502 

(ciais.  only) )  Commandant 

US  Army  Infantry  School 
ATTN:  ATSH-CD  (Security  Mgr.) 

Fort  Benning,  GA  31905-56^ 

(Unciass.  only)  1  Commandant 

US  Army  Infantry  School 
ATTN:  ATSH-CD-CSO-OR 
Fort  Benning,  GA  31905-5660 


(Class,  only)  j  Rand  Corporation 

P.O.  Box  2138 

Santa  Monica,  CA  90401-2138 


1  Air  Force  Armament  Laboratory 
ATTN:  AFATL/DLODL 
Eglin  AFB,  FL  32542-5000 


Aberdeen  Proving  Ground 
Dir,  USAMSAA 

ATTN:  AMXSY-D 

AMXSY-MP,  H.  Cohen 

Cdr,  USATECOM 

ATTN:  AMSTE-TO-F 
Cdr,  CRDEC,  AMCCOM 

ATTN:  SMCCR-RSP-A 
SMCCR-MU 
SMCCR-MSI 

Dir,  VLAMO 

ATTN:  AMSLC-VL-D 
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No.  of 

Copies  Organization 

2  Director 

Defense  Advanced  Research 
Projects  Agency 
ATTN :  J .  Lupo 

J .  Richardson 
1400  Wilson  Boulevard 
Arlington,  VA  22209 

2  HQDA 

ATTN;  SARD-TR,  B.  Zimmerman 
I .  Szkrybalo 
Washington,  DC  20310 

1  HQ,  US  Army  Materiel  Command 

ATTN:  AMCICP-AD,  B.  Dunetz 
5001  Eisenhower  Avenue 
Alexandria,  VA  22333-0001 

13  Cmdr,  Armament  R&D  Center 

US  Army  AMCCOM 
ATTN;  SMCAR-TSS 

SMCAR-AEE-BR,  B.  Brodman 
SMCAR-AEE-B,  D.  Downs 
SMCAR-AEE-BR,  W.  Seals 
A.  Beardell 
SMCAR-AEE-W,  N.  Slagg 
SMCAR-AEE,  A.  Bracuti 
J .  Lannon 
M.  Gupta 
J .  Salo 
D .  Chieu 

SMCAR-FSS-D,  L.  Frauen 
SMCAR-FSA-S,  H.  Liberman 
Picatinny  Arsenal,  NJ07806-5000 

3  Commander 
Armament  R6dD  Center 
US  Army  AMCCOM 

ATTN:  SMCAR-FSS-DA,  Bldg  94 
J .  Feneck 
R .  Kopmann 
J.  Irizarry 
Picatinny  Arsenal ,  NJ 
07806-5000 


No .  of 

Copies  Organization 

4  Director 

Benet  Weapons  Laboratory 
Armament  RD&E  Center 
US  Army  AMCCOM 
ATTN:  SMCAR-CCB-DS, 

E.  Conroy 
A .  Graham 

SMCAR-CCB,  L.  Johnson 
SMCAR-CCB-S,  F.  Reiser 
Watervliet,  NY  12189-4050 

1  Commander 

Materials  Technology  Lab 
US  Army  Laboratory  Cmd 
ATTN;  SLCMT-MCM-SB 
M.  Levy 

Watertown,  MA  02172-0001 


1  Commander 

CECOM  R&D  Technical  Library 
ATTN:  ASNC-ELC-IT  (Rpts  Sec) 
Ft.  Monmouth,  NJ  07703-5301 

1  Commander 

US  Army  Laboratory  Cmd 
ATTN:  SLCHD-TA-L 

2800  Powder  Mill  Rd 
Adelphi,  MD  20783-1145 
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DISTRIBUTION  LIST 


No .  of 

Copies  Organization 

1  Commander 

US  Army  Belvoir  R&D  Ctr 
ATTN:  STRBE-WC 

Tech  Library  (Vault)  B-315 
Fort  Belvoir,  VA  22060-5606 

1  Commander 

US  Army  Research  Office 
ATTN :  Tech  Library 
PO  Box  12211 

Research  Triangle  Park,  NC 
27709-2211 

1  Commander 

Armament  Rsch  &  Dev  Ctr 
US  Army  Armament,  Munitions 
and  Chemical  Command 
ATTN:  SMCAR-CCS-C,  T  Hung 

Picatinny  Arsenal,  NJ 
07806-3000 

2  Commandant 

US  Army  Field  Artillery  School 
ATTN:  ATSF-CMW 

ATSF-TSM-CN, 

J.  Spicer 
Ft  Sill,  OK  73503 

1  Commandant 

US  Army  Armor  Center 
ATTN:  ATSB-CD-MLD 
Ft  Knox,  KY  40121 

1  Commander 

Naval  Surface  Weapons  Center 
ATTN:  D.A.  Wilson,  Code  G31 
Dahlgren,  VA  22448-5000 

1  Commander 

Naval  Surface  Weapons  Center 
ATTN:  Code  G33,  J.  East 
Dahlgren,  VA  22448-5000 


No .  of 

Copies  Organization 

2  Commander 

US  Naval  Surface  Weapons  Ctr 
ATTN:  0.  Dengel 

K.  Thorsted 

Silver  Spring,  MD  20902-5000 

1  Cosunandar 

Naval  Weapons  Center 
China  Lake,  CA  93555-6001 

1  Superintendent 

Naval  Postgraduate  School 
Dept  of  Mechanical  Engr 
ATTN:  Code  1424,  Library 

Monterey,  CA  93943 

1  AFOSR/NA  (L.  Caveny) 

Bldg  410 

Bolling  AFB,  DC  20332 

1  Commandant 

USAFAS 

ATTN:  ATSF-TSM-CN 
Ft  Sill,  OK  73503-5600 

1  Director 

Jet  Propulsion  Lab 
ATTN :  Tech  Library 
4800  Oak  Grove  Drive 
Pasadena,  CA  91109 

2  Director 

National  Aeronautics  and 
Space  Administration 
ATTN:  MS -60 3,  Tech  Lib 

MS -86,  Dr.  Povinelli 
21000  Brookpark  Road 
Lev'is  Research  Center 
Cleveland,  OH  44135 

1  Director 

National  Aeronautics  and 
Space  Administration 
Manned  Spacecraft  Center 
Houston,  TX  77058 


159 


1 


Central  Intelligence  Agency 
Office  of  Central  Reference 
Dissemination  Branch 
Room  GE-47  HQS 
Washington,  DC  20502 

Central  Intelligence  Agency 
ATTN:  Joseph  E.  Backofen 
HQ  Room  5F22 
Washington,  DC  20505 

Calspan  Corporation 
ATTN ;  Tech  Library 
PO  Box  400 
Buffalo,  NY  14225 

General  Electric  Ord  Sys  Div 
ATTN:  J.  Mandzy,  OP43-220 
R.E.  Mayer 

H.  West 
W.  Pasko 
R.  Pate 

I .  Magoon 

J.  Scudiere 
Minh  Luu 

100  Plastics  Avenue 
Pittsfield,  MA  01201-3698 

General  Electric  Company 
Armament  Systems  Department 
ATTN:  D.  Maher 
Burlington,  VT  05401 

Honeywell  Inc . 

ATTN:  R.E.  Tompkins 
MN38-3300 

10400  Yellow  Circle  Drive 
Minnetonka,  MN  55343 

IITRI 

ATTN:  Library 
10  W.  35th  St 
Chicago,  IL  60616 


Olin  Chemicals  Research 
ATTN :  David  Gavin 

PO  Box  586 

Chesire,  CT  06410-0586 

2  Olin  Corporation 

ATTN:  Victor  A.  Corso 

Dr.  Ronald  L.  Dotson 
PO  Box  30-9644 
New  Haven,  CT  06536 

1  Paul  Gough  Associates 

ATTN:  Paul  Gough 

1048  South  Street 
Portsmouth,  NH  03801-5423 
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